New Upstream Release - racket-mode
Ready changes
Summary
Merged new upstream version: 20230508git0 (was: 20210916git0).
Diff
diff --git a/.elpaignore b/.elpaignore
new file mode 100644
index 0000000..45f3a09
--- /dev/null
+++ b/.elpaignore
@@ -0,0 +1,17 @@
+.dir-locals.el
+.elpaignore
+.git
+.github
+.gitignore
+Makefile
+racket/compiled
+racket/commands/compiled
+test
+doc/Makefile
+doc/README.org
+doc/arch-pict.rkt
+doc/generate.el
+doc/*.css
+doc/*.html
+doc/*.info
+doc/*.org
diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
index 4f27c2b..1721f08 100644
--- a/.github/workflows/test.yml
+++ b/.github/workflows/test.yml
@@ -5,7 +5,7 @@ on:
pull_request:
jobs:
- test:
+ ubuntu:
runs-on: ubuntu-latest
strategy:
fail-fast: false
@@ -13,7 +13,7 @@ jobs:
emacs_version:
- '25.1' # our minimum supported version
- '26.3'
- - '27.1' # most recent release
+ - '28.1' # most recent release
racket_version:
- '6.9' # our minimum supported version
- 'stable' # most recent release
@@ -28,7 +28,7 @@ jobs:
- emacs_version: 'snapshot'
racket_version: 'current'
allow_failure: true
- name: Test Emacs ${{ matrix.emacs_version }} and Racket ${{ matrix.racket_version }}
+ name: Ubuntu Emacs ${{ matrix.emacs_version }} and Racket ${{ matrix.racket_version }}
steps:
- name: Checkout
uses: actions/checkout@master
@@ -37,11 +37,13 @@ jobs:
with:
version: ${{ matrix.emacs_version }}
- name: Install Racket
- uses: Bogdanp/setup-racket@v1.5
+ uses: Bogdanp/setup-racket@v1.9
with:
architecture: 'x64'
distribution: 'full'
version: ${{ matrix.racket_version }}
+ - name: Show versions
+ run: make show-versions
- name: Install Emacs Packages
run: make deps
- name: Compile Elisp
@@ -49,32 +51,33 @@ jobs:
- name: Run Tests
run: make test
- test_windows:
+ windows:
runs-on: windows-latest
strategy:
fail-fast: false
matrix:
emacs_version:
- - '27.1' # most recent release
+ - '28.1' # most recent release
racket_version:
- 'stable' # most recent release
- name: Test Windows Emacs ${{ matrix.emacs_version }} and Racket ${{ matrix.racket_version }}
+ name: Windows Emacs ${{ matrix.emacs_version }} and Racket ${{ matrix.racket_version }}
steps:
- name: Checkout
uses: actions/checkout@master
- - name: Install Emacs on Windows
+ - name: Install Emacs
uses: jcs090218/setup-emacs-windows@master
with:
version: ${{ matrix.emacs_version }}
- name: Install Racket
- uses: Bogdanp/setup-racket@v1.5
+ uses: Bogdanp/setup-racket@v1.9
with:
architecture: 'x64'
distribution: 'full'
- platform: 'windows'
version: ${{ matrix.racket_version }}
- name: Install Emacs Packages
run: make deps
+ - name: Compile Elisp
+ run: make compile
- name: Run Tests
- run: emacs --batch --no-site-file -q -eval "(progn (add-to-list (quote load-path) nil) (package-initialize))" -l ert -l racket-tests.el -f ert-run-tests-batch-and-exit
+ run: make test
diff --git a/.gitignore b/.gitignore
index becafcc..9fd6770 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,3 +5,8 @@ doc/*.texi~
doc/*.info
doc/reference.org
doc/racket-mode.html
+doc/*.png
+doc/*.svg
+# ELPA-generated files
+/racket-mode-autoloads.el
+/racket-mode-pkg.el
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
deleted file mode 100644
index 9c5f9a1..0000000
--- a/CONTRIBUTING.md
+++ /dev/null
@@ -1,115 +0,0 @@
-# Reporting bugs
-
-If you're going to report a bug -- thank you!
-
-Please use <kbd>M-x racket-bug-report</kbd> to generate a buffer with
-information that will help to reproduce and understand the bug:
-
-- Emacs version
-- value of important Racket Mode variables
-- minor-modes that are active
-
-Please copy this and paste in your bug report.
-
-# Making pull requests
-
-If you'd like to make a pull request -- thank you!
-
-Here is some information to help you.
-
-## Package dependencies
-
-Racket Mode depends on some other packages. In `racket-mode.el` see
-the `Package-Requires:` line.
-
-You can install these manually with <kbd>M-x package-install</kbd>,
-or, run `make deps`. The latter is also used by `.travis.yml`.
-
-The recent trend has been for Racket Mode to depend on fewer packages,
-not more. For example `dash.el` was dropped in favor of using native
-Emacs Lisp constructs. Likewise `s.el`.
-
-Having said that, if your PR truly needs a new package, please make
-sure your PR updates all of:
-
-1. the `Package-Requires:` line in `racket-mode.el`
-2. the `deps` target in `makefile`
-
-## Pointing Emacs to your Git clone
-
-After ensuring all dependencies of Racket Mode are installed, it
-suffices to add the path to your local clone of Racket Mode to
-`load-path` and require the package:
-
-```elisp
-(add-to-list 'load-path "/path/to/the/git-clone/dir")
-(require 'racket-mode)
-```
-
-Note that these lines will override any previous references to Racket
-Mode in your Emacs configuration. In particular, if you have Racket
-Mode installed as an Emacs package, after evaluating these lines you
-will use Racket Mode from your local Git repository.
-
-If you use `use-package`, you can simply replace
-
-```elisp
-(use-package racket-mode
- :ensure t)
-```
-
-with
-
-```elisp
-(use-package racket-mode
- :load-path "/path/to/the/git-clone/dir")
-```
-
-You might also need to:
-
-* run <kbd>M-x package-delete</kbd> <kbd>racket-mode</kbd> so that the
- ELPA package is not loaded from `.emacs.d/elpa`,
-
-* restart Emacs.
-
-## doc/generate.el
-
-We generate reference documentation from doc strings for commands, variables, and faces.
-
-- If you add a brand-new command, `defcustom`, or `defface`, please
- also add it to appropriate list in `doc/generate.el`.
-
-- Whenever you edit a doc string for a command, `defcustom`, or
- `defface`, please `cd doc && make clean && make` and commit the
- updated files.
-
-## Tests
-
-Currently tests are on the light side. More are welcome.
-
-Please do run `make test` to ensure your changes pass the existing
-tests. Travis CI will also do this automatically on your pull request.
-
-### Indentation
-
-Indentation is tested by comparing to a couple reference files,
-`example/*.rkt`.
-
-If you change indentation intentionally, you may need to refresh each
-reference file:
-
-1. Open it.
-2. Reindent it all
- 1. <kbd>C-x h</kbd>
- 2. <kbd>M-C-\\</kbd>
-3. Save it.
-
-### Font-lock
-
-Font-lock is tested by comparing to a couple reference files,
-`example/*.rkt.faceup`.
-
-If you change font-lock, you may need to refresh each reference file:
-
-1. Open it.
-2. <kbd>M-x faceup-write-file</kbd>
diff --git a/CONTRIBUTING.org b/CONTRIBUTING.org
new file mode 100644
index 0000000..d48a513
--- /dev/null
+++ b/CONTRIBUTING.org
@@ -0,0 +1,124 @@
+* Reporting bugs
+
+If you're going to report a bug --- thank you!
+
+Please use =M-x racket-bug-report= to generate a buffer with
+information that will help to reproduce and understand the bug:
+
+- Emacs version.
+- Value of important Racket Mode variables.
+- Minor modes that are active.
+
+Please copy that and paste in your bug report.
+
+* Making pull requests
+
+If you'd like to make a pull request --- thank you!
+
+Here is some information to help you.
+
+** Package dependencies
+
+For end users, Racket Mode currently has zero dependencies on other
+packages --- in =racket-mode.el= =Package-Requires:= is just:
+
+#+BEGIN_SRC elisp
+;; Package-Requires: ((emacs "25.1"))
+#+END_SRC
+
+For hacking on Racket Mode and to run tests, a couple packages are
+required. To install them: =make deps=.
+
+The recent trend has been for Racket Mode to depend on fewer packages,
+not more. For example =dash.el= and =s.el= were dropped in favor of
+directly using the built-in Emacs functions wrapped by those packages.
+
+Having said that, if your PR proposes adding a dependency on a new
+package that you think is worthwhile, please make sure your PR updates
+both:
+
+1. the =Package-Requires:= line in =racket-mode.el=
+2. the =deps= target in =Makefile=
+
+** Pointing Emacs to your Git clone
+
+After installing dependencies you should just need to add the path to
+your local clone of Racket Mode to =load-path= and require it:
+
+#+BEGIN_SRC elisp
+(add-to-list 'load-path "/path/to/the/git-clone/dir")
+(require 'racket-mode)
+#+END_SRC
+
+If you use =use-package=, you can simply replace
+
+#+BEGIN_SRC elisp
+(use-package racket-mode
+ :ensure t)
+#+END_SRC
+
+with
+
+#+BEGIN_SRC elisp
+(use-package racket-mode
+ :load-path "/path/to/the/git-clone/dir")
+#+END_SRC
+
+If you have previously been using Racket Mode as a package installed
+from MELPA, you might want to remove that, at least for the duration
+of your hacking:
+
+- =M-x package-delete= and enter =racket-mode=.
+- Restart Emacs.
+
+** Generating reference documentation
+
+We generate reference documentation from doc strings for commands,
+variables, and faces.
+
+- If you add a brand-new command =defun=, =defcustom=, or =defface=,
+ please also add it to the appropriate list in =doc/generate.el=.
+
+- Whenever you edit a doc string for a command =defun=, =defcustom=,
+ or =defface=, please =cd doc && make clean docs=, and commit the
+ updated files.
+
+** Tests
+
+Currently tests are on the light side. More are welcome.
+
+Please do run =make test= locally to ensure your changes pass the
+existing tests.
+
+GitHub Actions also does =make test= automatically on your pull
+request.
+
+GitHub branch protection is enabled for the main branch --- merges
+are blocked until tests pass.
+
+*** Example files for indentation and font-lock
+
+Some Racket Mode tests apply indentation and font-lock to the
+=test/example/example.rkt= and =test/example/indent.rkt= files and
+compare the result to corresponding =.faceup= files (generated by the
+=faceup= package).
+
+As a result, if your PR intentionally modifies indentation or
+font-lock, you may need to regenerate the =.faceup= files. To do so:
+
+1. Disable any personal Emacs features that affect font-lock or
+ indentation. For example you may need to =M-x global-paren-mode=
+ and =M-x prettify-symbols-mode= to disable those.
+
+2. For each =.rkt= file:
+
+ - Visit the =.rkt= file.
+
+ - =M-x mark-buffer= and =M-x indent-region=.
+
+ - =M-x save-buffer= to save the =.rkt= file.
+
+ - =M-x faceup-write-file= and answer, yes, replace the existing
+ =.faceup= file.
+
+3. Re-enable any personal features you disabled in step 1.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f288702
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The GNU General Public License is a free, copyleft license for
+software and other kinds of works.
+
+ The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+the GNU General Public License is intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains free
+software for all its users. We, the Free Software Foundation, use the
+GNU General Public License for most of our software; it applies also to
+any other work released this way by its authors. You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+ To protect your rights, we need to prevent others from denying you
+these rights or asking you to surrender the rights. Therefore, you have
+certain responsibilities if you distribute copies of the software, or if
+you modify it: responsibilities to respect the freedom of others.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must pass on to the recipients the same
+freedoms that you received. You must make sure that they, too, receive
+or can get the source code. And you must show them these terms so they
+know their rights.
+
+ Developers that use the GNU GPL protect your rights with two steps:
+(1) assert copyright on the software, and (2) offer you this License
+giving you legal permission to copy, distribute and/or modify it.
+
+ For the developers' and authors' protection, the GPL clearly explains
+that there is no warranty for this free software. For both users' and
+authors' sake, the GPL requires that modified versions be marked as
+changed, so that their problems will not be attributed erroneously to
+authors of previous versions.
+
+ Some devices are designed to deny users access to install or run
+modified versions of the software inside them, although the manufacturer
+can do so. This is fundamentally incompatible with the aim of
+protecting users' freedom to change the software. The systematic
+pattern of such abuse occurs in the area of products for individuals to
+use, which is precisely where it is most unacceptable. Therefore, we
+have designed this version of the GPL to prohibit the practice for those
+products. If such problems arise substantially in other domains, we
+stand ready to extend this provision to those domains in future versions
+of the GPL, as needed to protect the freedom of users.
+
+ Finally, every program is threatened constantly by software patents.
+States should not allow patents to restrict development and use of
+software on general-purpose computers, but in those that do, we wish to
+avoid the special danger that patents applied to a free program could
+make it effectively proprietary. To prevent this, the GPL assures that
+patents cannot be used to render the program non-free.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ TERMS AND CONDITIONS
+
+ 0. Definitions.
+
+ "This License" refers to version 3 of the GNU General Public License.
+
+ "Copyright" also means copyright-like laws that apply to other kinds of
+works, such as semiconductor masks.
+
+ "The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+ To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of an
+exact copy. The resulting work is called a "modified version" of the
+earlier work or a work "based on" the earlier work.
+
+ A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+ To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+ To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user through
+a computer network, with no transfer of a copy, is not conveying.
+
+ An interactive user interface displays "Appropriate Legal Notices"
+to the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+ 1. Source Code.
+
+ The "source code" for a work means the preferred form of the work
+for making modifications to it. "Object code" means any non-source
+form of a work.
+
+ A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+ The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+ The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+ The Corresponding Source need not include anything that users
+can regenerate automatically from other parts of the Corresponding
+Source.
+
+ The Corresponding Source for a work in source code form is that
+same work.
+
+ 2. Basic Permissions.
+
+ All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+ You may make, run and propagate covered works that you do not
+convey, without conditions so long as your license otherwise remains
+in force. You may convey covered works to others for the sole purpose
+of having them make modifications exclusively for you, or provide you
+with facilities for running those works, provided that you comply with
+the terms of this License in conveying all material for which you do
+not control copyright. Those thus making or running the covered works
+for you must do so exclusively on your behalf, under your direction
+and control, on terms that prohibit them from making any copies of
+your copyrighted material outside their relationship with you.
+
+ Conveying under any other circumstances is permitted solely under
+the conditions stated below. Sublicensing is not allowed; section 10
+makes it unnecessary.
+
+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+ No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+ When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such circumvention
+is effected by exercising rights under this License with respect to
+the covered work, and you disclaim any intention to limit operation or
+modification of the work as a means of enforcing, against the work's
+users, your or third parties' legal rights to forbid circumvention of
+technological measures.
+
+ 4. Conveying Verbatim Copies.
+
+ You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+ You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+ 5. Conveying Modified Source Versions.
+
+ You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these conditions:
+
+ a) The work must carry prominent notices stating that you modified
+ it, and giving a relevant date.
+
+ b) The work must carry prominent notices stating that it is
+ released under this License and any conditions added under section
+ 7. This requirement modifies the requirement in section 4 to
+ "keep intact all notices".
+
+ c) You must license the entire work, as a whole, under this
+ License to anyone who comes into possession of a copy. This
+ License will therefore apply, along with any applicable section 7
+ additional terms, to the whole of the work, and all its parts,
+ regardless of how they are packaged. This License gives no
+ permission to license the work in any other way, but it does not
+ invalidate such permission if you have separately received it.
+
+ d) If the work has interactive user interfaces, each must display
+ Appropriate Legal Notices; however, if the Program has interactive
+ interfaces that do not display Appropriate Legal Notices, your
+ work need not make them do so.
+
+ A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+ 6. Conveying Non-Source Forms.
+
+ You may convey a covered work in object code form under the terms
+of sections 4 and 5, provided that you also convey the
+machine-readable Corresponding Source under the terms of this License,
+in one of these ways:
+
+ a) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by the
+ Corresponding Source fixed on a durable physical medium
+ customarily used for software interchange.
+
+ b) Convey the object code in, or embodied in, a physical product
+ (including a physical distribution medium), accompanied by a
+ written offer, valid for at least three years and valid for as
+ long as you offer spare parts or customer support for that product
+ model, to give anyone who possesses the object code either (1) a
+ copy of the Corresponding Source for all the software in the
+ product that is covered by this License, on a durable physical
+ medium customarily used for software interchange, for a price no
+ more than your reasonable cost of physically performing this
+ conveying of source, or (2) access to copy the
+ Corresponding Source from a network server at no charge.
+
+ c) Convey individual copies of the object code with a copy of the
+ written offer to provide the Corresponding Source. This
+ alternative is allowed only occasionally and noncommercially, and
+ only if you received the object code with such an offer, in accord
+ with subsection 6b.
+
+ d) Convey the object code by offering access from a designated
+ place (gratis or for a charge), and offer equivalent access to the
+ Corresponding Source in the same way through the same place at no
+ further charge. You need not require recipients to copy the
+ Corresponding Source along with the object code. If the place to
+ copy the object code is a network server, the Corresponding Source
+ may be on a different server (operated by you or a third party)
+ that supports equivalent copying facilities, provided you maintain
+ clear directions next to the object code saying where to find the
+ Corresponding Source. Regardless of what server hosts the
+ Corresponding Source, you remain obligated to ensure that it is
+ available for as long as needed to satisfy these requirements.
+
+ e) Convey the object code using peer-to-peer transmission, provided
+ you inform other peers where the object code and Corresponding
+ Source of the work are being offered to the general public at no
+ charge under subsection 6d.
+
+ A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+ A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal, family,
+or household purposes, or (2) anything designed or sold for incorporation
+into a dwelling. In determining whether a product is a consumer product,
+doubtful cases shall be resolved in favor of coverage. For a particular
+product received by a particular user, "normally used" refers to a
+typical or common use of that class of product, regardless of the status
+of the particular user or of the way in which the particular user
+actually uses, or expects or is expected to use, the product. A product
+is a consumer product regardless of whether the product has substantial
+commercial, industrial or non-consumer uses, unless such uses represent
+the only significant mode of use of the product.
+
+ "Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to install
+and execute modified versions of a covered work in that User Product from
+a modified version of its Corresponding Source. The information must
+suffice to ensure that the continued functioning of the modified object
+code is in no case prevented or interfered with solely because
+modification has been made.
+
+ If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+ The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or updates
+for a work that has been modified or installed by the recipient, or for
+the User Product in which it has been modified or installed. Access to a
+network may be denied when the modification itself materially and
+adversely affects the operation of the network or violates the rules and
+protocols for communication across the network.
+
+ Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+ 7. Additional Terms.
+
+ "Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+ When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+ Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders of
+that material) supplement the terms of this License with terms:
+
+ a) Disclaiming warranty or limiting liability differently from the
+ terms of sections 15 and 16 of this License; or
+
+ b) Requiring preservation of specified reasonable legal notices or
+ author attributions in that material or in the Appropriate Legal
+ Notices displayed by works containing it; or
+
+ c) Prohibiting misrepresentation of the origin of that material, or
+ requiring that modified versions of such material be marked in
+ reasonable ways as different from the original version; or
+
+ d) Limiting the use for publicity purposes of names of licensors or
+ authors of the material; or
+
+ e) Declining to grant rights under trademark law for use of some
+ trade names, trademarks, or service marks; or
+
+ f) Requiring indemnification of licensors and authors of that
+ material by anyone who conveys the material (or modified versions of
+ it) with contractual assumptions of liability to the recipient, for
+ any liability that these contractual assumptions directly impose on
+ those licensors and authors.
+
+ All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+ If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+ Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions;
+the above requirements apply either way.
+
+ 8. Termination.
+
+ You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+ However, if you cease all violation of this License, then your
+license from a particular copyright holder is reinstated (a)
+provisionally, unless and until the copyright holder explicitly and
+finally terminates your license, and (b) permanently, if the copyright
+holder fails to notify you of the violation by some reasonable means
+prior to 60 days after the cessation.
+
+ Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+ Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+ 9. Acceptance Not Required for Having Copies.
+
+ You are not required to accept this License in order to receive or
+run a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+ 10. Automatic Licensing of Downstream Recipients.
+
+ Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+ An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+ You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+ 11. Patents.
+
+ A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+ A contributor's "essential patent claims" are all patent claims
+owned or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+ Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+ In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+ If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+ If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+ A patent license is "discriminatory" if it does not include within
+the scope of its coverage, prohibits the exercise of, or is
+conditioned on the non-exercise of one or more of the rights that are
+specifically granted under this License. You may not convey a covered
+work if you are a party to an arrangement with a third party that is
+in the business of distributing software, under which you make payment
+to the third party based on the extent of your activity of conveying
+the work, and under which the third party grants, to any of the
+parties who would receive the covered work from you, a discriminatory
+patent license (a) in connection with copies of the covered work
+conveyed by you (or copies made from those copies), or (b) primarily
+for and in connection with specific products or compilations that
+contain the covered work, unless you entered into that arrangement,
+or that patent license was granted, prior to 28 March 2007.
+
+ Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+ 12. No Surrender of Others' Freedom.
+
+ If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you may
+not convey it at all. For example, if you agree to terms that obligate you
+to collect a royalty for further conveying from those to whom you convey
+the Program, the only way you could satisfy both those terms and this
+License would be to refrain entirely from conveying the Program.
+
+ 13. Use with the GNU Affero General Public License.
+
+ Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU Affero General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the special requirements of the GNU Affero General Public License,
+section 13, concerning interaction through a network will apply to the
+combination as such.
+
+ 14. Revised Versions of this License.
+
+ The Free Software Foundation may publish revised and/or new versions of
+the GNU General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Program specifies that a certain numbered version of the GNU General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU General Public License, you may choose any version ever published
+by the Free Software Foundation.
+
+ If the Program specifies that a proxy can decide which future
+versions of the GNU General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+ Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+ 15. Disclaimer of Warranty.
+
+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. Limitation of Liability.
+
+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+ 17. Interpretation of Sections 15 and 16.
+
+ If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+state the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper mail.
+
+ If the program does terminal interaction, make it output a short
+notice like this when it starts in an interactive mode:
+
+ <program> Copyright (C) <year> <name of author>
+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, your program's commands
+might be different; for a GUI interface, you would use an "about box".
+
+ You should also get your employer (if you work as a programmer) or school,
+if any, to sign a "copyright disclaimer" for the program, if necessary.
+For more information on this, and how to apply and follow the GNU GPL, see
+<https://www.gnu.org/licenses/>.
+
+ The GNU General Public License does not permit incorporating your program
+into proprietary programs. If your program is a subroutine library, you
+may consider it more useful to permit linking proprietary applications with
+the library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License. But first, please read
+<https://www.gnu.org/licenses/why-not-lgpl.html>.
diff --git a/Makefile b/Makefile
index 2c2440b..dac376a 100644
--- a/Makefile
+++ b/Makefile
@@ -1,49 +1,71 @@
-EMACS ?= emacs
-
-RACKET ?= racket
-
-BATCHEMACS = $(EMACS) --batch --no-site-file -q -eval '(progn (add-to-list (quote load-path) nil) (package-initialize))'
-
-BYTECOMP = $(BATCHEMACS) -eval '(progn (require (quote bytecomp)) (setq byte-compile-warnings t) (setq byte-compile-error-on-warn t))' -f batch-byte-compile
-
.PHONY : help show-versions clean compile deps test test-elisp test-racket test-slow
help:
@echo "Targets: show-versions, clean, compile, deps, test, test-elisp, test-racket, test-slow"
+# Allow running with an emacs or racket executable other than the
+# default on PATH. e.g. `EMACS=/path/to/emacs make`.
+EMACS ?= emacs
+RACKET ?= racket
+
show-versions:
@echo `which $(RACKET)`
@$(RACKET) --version
@echo `which $(EMACS)`
@$(EMACS) --version
+batch-emacs := $(EMACS) --batch -Q -L . --eval '(package-initialize)'
+
+byte-compile := \
+ $(batch-emacs) \
+ -l bytecomp \
+ --eval '(setq byte-compile-warnings t)' \
+ --eval '(setq byte-compile-error-on-warn t)' \
+ -f batch-byte-compile
+
%.elc : %.el
- $(BYTECOMP) $<
+ $(byte-compile) $<
-ELCS := $(patsubst %.el,%.elc,$(wildcard *.el))
+# Build an .elc file for every .el file in the top dir.
+elc-files := $(patsubst %.el,%.elc,$(wildcard *.el))
clean:
- -rm $(ELCS) 2> /dev/null
+ -rm $(elc-files) 2> /dev/null
+
+compile: check-declares $(elc-files)
-compile: show-versions $(ELCS)
+check-declares:
+ $(batch-emacs) \
+ -l check-declare \
+ --eval '(unless (eq system-type (quote windows-nt)) (when (check-declare-directory default-directory) (kill-emacs 1)))'
# Install Emacs packages we depend on for development and/or testing.
-# Intended for one-time use by developers and for Travis CI. (Normal
-# users get a subset of these deps automatically as a result of our
-# Package-Requires in racket-mode.el)
+# Intended to be run once per machine by developers, as well as by CI.
+# (Normal users get a subset of these deps automatically as a result
+# of our Package-Requires in racket-mode.el.)
+melpa-url := https://melpa.org/packages/
deps:
- $(BATCHEMACS) -eval '(progn (add-to-list (quote package-archives) (cons "melpa" "http://melpa.org/packages/")) (package-initialize) (package-refresh-contents) (package-install (quote faceup)) (package-install (quote paredit)) (package-install (quote pos-tip)))'
+ $(batch-emacs) \
+ --eval '(add-to-list (quote package-archives) (cons "melpa" "$(melpa-url)"))' \
+ --eval '(package-initialize)' \
+ --eval '(package-refresh-contents)' \
+ --eval '(package-install (quote faceup))' \
+ --eval '(package-install (quote paredit))'
test: test-racket test-elisp
+test-elisp:
+ $(batch-emacs) \
+ -l ert \
+ -l test/racket-tests.el \
+ --eval '(setq racket-program "$(RACKET)")' \
+ -f ert-run-tests-batch-and-exit
+
test-racket:
- $(RACKET) -l raco test ./racket/test/
+ $(RACKET) -l raco test ./test/racket/
$(RACKET) -l raco test -x ./racket/*.rkt
$(RACKET) -l raco test -x ./racket/commands/*.rkt
-test-elisp:
- $(BATCHEMACS) -l ert -l racket-tests.el -eval '(setq racket-program "$(RACKET)")' -f ert-run-tests-batch-and-exit
-
test-slow:
$(RACKET) -l raco test --submodule slow-test ./racket/imports.rkt
$(RACKET) -l raco test --submodule slow-test ./racket/commands/check-syntax.rkt
diff --git a/README.md b/README.md
deleted file mode 100644
index a7a0cbb..0000000
--- a/README.md
+++ /dev/null
@@ -1,32 +0,0 @@
-# Racket mode for GNU Emacs
-
-[](https://github.com/greghendershott/racket-mode/actions)
-[](https://melpa.org/#/racket-mode)
-[](https://www.racket-mode.com/)
-
-This provides a major mode to edit [Racket] source files, as well as a
-major mode for a Racket REPL. The edit/run experience is similar to
-[DrRacket].
-
-[Racket]: https://www.racket-lang.org/
-[DrRacket]: https://docs.racket-lang.org/drracket/
-
-Compatible with **Emacs 25.1+** and **Racket 6.9+**.
-
-## Documentation
-
-See the [Guide and Reference](https://www.racket-mode.com/).
-
-## Contributing
-
-Pull requests are welcome; please [read this](CONTRIBUTING.md).
-
-[Acknowledgments](THANKS.md).
-
-## Alternatives
-
-- Emacs' built-in `scheme-mode` major mode plus the minor modes [Quack]
- and/or [Geiser].
-
-[Quack]: https://www.neilvandyke.org/quack/
-[Geiser]: https://www.nongnu.org/geiser/
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..2ec5cd2
--- /dev/null
+++ b/README.org
@@ -0,0 +1,29 @@
+* Racket mode for GNU Emacs
+
+[[https://github.com/greghendershott/racket-mode/actions][https://github.com/greghendershott/racket-mode/workflows/CI/badge.svg]]
+[[https://melpa.org/#/racket-mode][https://melpa.org/packages/racket-mode-badge.svg]]
+[[https://elpa.nongnu.org/nongnu/racket-mode.html][https://elpa.nongnu.org/nongnu/racket-mode.svg]]
+[[https://www.racket-mode.com/][https://img.shields.io/badge/Docs-Documentation-blue.svg]]
+
+A variety of Emacs major and minor modes for [[https://www.racket-lang.org/][Racket]]: edit, REPL,
+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+*.
+
+** Documentation
+
+See the [[https://www.racket-mode.com/][Guide and Reference]].
+
+** Contributing
+
+Pull requests are welcome; please see [[https://github.com/greghendershott/racket-mode/blob/master/CONTRIBUTING.org][CONTRIBUTING.org]].
+
+** Acknowledgments
+
+[[https://github.com/greghendershott/racket-mode/blob/master/THANKS.org][THANKS.org]].
+
+** Alternatives
+
+- Emacs' built-in `scheme-mode` major mode plus the minor modes [[https://www.neilvandyke.org/quack/][Quack]]
+ and/or [[https://www.nongnu.org/geiser/][Geiser]].
diff --git a/THANKS.md b/THANKS.md
deleted file mode 100644
index e47636f..0000000
--- a/THANKS.md
+++ /dev/null
@@ -1,23 +0,0 @@
-# Contributors
-
-Thanks to everyone who has contributed:
-
-- [Pull Requests](https://github.com/greghendershott/racket-mode/graphs/contributors)
-- [Issues](https://github.com/greghendershott/racket-mode/issues?utf8=%E2%9C%93&q=is%3Aissue)
-
-# Acknowledgements
-
-- The existing Emacs Scheme mode and Inferior Scheme mode.
-
-- The source code for for [Quack] by Neil Van Dyke provided a model
- for many of the scheme-indent-function settings, smart paren
- closing, and pretty lambda.
-
-- The source code for [Geiser] by Jose A. Ortega Ruiz helped me
- understand how to support completions and especially company-mode.
- In addition, I was able to make heavy use of [gcr's pull request to
- Geiser] for displaying images in the REPL.
-
-[Geiser]: http://www.nongnu.org/geiser/
-[Quack]: http://www.neilvandyke.org/quack/
-[gcr's pull request to Geiser]: https://github.com/jaor/geiser/pull/1
diff --git a/THANKS.org b/THANKS.org
new file mode 100644
index 0000000..1ab22a6
--- /dev/null
+++ b/THANKS.org
@@ -0,0 +1,16 @@
+* Contributors
+
+Thanks to everyone who has contributed [[https://github.com/greghendershott/racket-mode/graphs/contributors][pull requests]] and [[https://github.com/greghendershott/racket-mode/issues?utf8%3D%25E2%259C%2593&q%3Dis%253Aissue][issues]].
+
+** Acknowledgements
+
+- The existing Emacs Scheme mode and Inferior Scheme mode.
+
+- The source code for for [[http://www.neilvandyke.org/quack/][Quack]] by Neil Van Dyke provided a model for
+ many of the scheme-indent-function settings, smart paren closing,
+ and pretty lambda.
+
+- The source code for [[http://www.nongnu.org/geiser/][Geiser]] by Jose A. Ortega Ruiz helped me
+ understand how to support completions and especially company-mode.
+ In addition, I was able to make heavy use of a pull request to
+ display images in the REPL.
diff --git a/debian/changelog b/debian/changelog
index 615d13d..c5000a8 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+racket-mode (20230508git0-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk> Fri, 02 Jun 2023 01:36:55 -0000
+
racket-mode (20210916git0-2) unstable; urgency=medium
* Enable (nontrivial) autopkgtests
diff --git a/doc/Makefile b/doc/Makefile
index 2b7070f..4693faa 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -1,17 +1,24 @@
-.PHONY: docs clean deploy
+.PHONY: doc docs images clean deploy
-docs: racket-mode.info racket-mode.html
+doc: images racket-mode.info racket-mode.html
+
+docs: doc
clean:
+ -rm scenario*.png
+ -rm scenario*.svg
-rm reference.org
-rm racket-mode.info
-rm racket-mode.html
+images:
+ racket arch-pict.rkt
+
reference.org: generate.el
emacs --batch -Q --eval '(progn (add-to-list (quote load-path) "${PWD}/../") (package-initialize))' -l generate.el --funcall 'racket-generate-reference.org'
racket-mode.texi: racket-mode.org reference.org
- emacs --batch -Q -l ox-texinfo racket-mode.org --eval "(setq indent-tabs-mode nil make-backup-files nil)" --funcall org-texinfo-export-to-texinfo
+ emacs --batch -Q -l ox-texinfo racket-mode.org --eval "(setq indent-tabs-mode nil make-backup-files nil org-src-preserve-indentation t)" --funcall org-texinfo-export-to-texinfo
racket-mode.info: racket-mode.texi
makeinfo --no-split $< -o $@
@@ -29,7 +36,12 @@ cfid := E1OG6O4MCHIO1Q
.PHONY: deploy
-deploy: racket-mode.html racket-mode.css
+deploy: racket-mode.html racket-mode.css images
$(aws) s3 cp racket-mode.html $(dest)/index.html
$(aws) s3 cp racket-mode.css $(dest)/racket-mode.css
+ $(aws) s3 cp scenario-0.svg $(dest)/scenario-0.svg
+ $(aws) s3 cp scenario-1.svg $(dest)/scenario-1.svg
+ $(aws) s3 cp scenario-2.svg $(dest)/scenario-2.svg
+ $(aws) s3 cp scenario-3.svg $(dest)/scenario-3.svg
+ $(aws) s3 cp scenario-4.svg $(dest)/scenario-4.svg
$(aws) cloudfront create-invalidation --distribution-id $(cfid) --paths "/*" > /dev/null
diff --git a/doc/arch-pict.rkt b/doc/arch-pict.rkt
new file mode 100644
index 0000000..fc25633
--- /dev/null
+++ b/doc/arch-pict.rkt
@@ -0,0 +1,148 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+#lang racket/base
+
+(require pict
+ pict/color
+ (only-in racket/draw make-color))
+
+(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))
+(define back-end-color (make-color #xF7 #xFF #xF7 1.0))
+
+(define (background #:color color p)
+ (cc-superimpose (filled-rectangle #:color color
+ (pict-width p)
+ (pict-height p))
+ p))
+
+;; Simplify usage of raw `frame` and `inset`. Nicer to supply as
+;; keyword arg prefixes rather than suffixes. Also handle common case
+;; of (inset (frame (inset __))). Also add background color.
+(define (box #:inset [in #f]
+ #:outset [out #f]
+ #:color [color #f]
+ #:background [bg #f]
+ #:segment [segment #f]
+ #:width [width #f]
+ p)
+ (let* ([p (if in (inset p in) p)]
+ [p (if bg (background #:color bg p) p)]
+ [p (frame #:color color
+ #:segment segment
+ #:line-width width
+ p)]
+ [p (if out (inset p out) p)])
+ p))
+
+(define (front-end)
+ (box
+ #:inset 5
+ #:outset 5
+ #:background front-end-color
+ (vl-append
+ (text "Emacs front end" '(bold))
+ (hc-append
+ (text "Command requests/responses 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.")))))
+
+(define (backend path)
+ (box
+ #:inset 5
+ #:color (light "black")
+ #:background back-end-color
+ (vc-append
+ 5
+ (text "Racket back end process" '(bold))
+ (box #:color (light "black") #:background (light "black")
+ #:inset 2 #:outset 6
+ (colorize (text path '(bold . modern)) "white"))
+ (ht-append
+ 10
+ (colorize
+ (box #:inset 5 (text "Commands"))
+ (if (regexp-match? #rx"^/[^:]+:" path) ssh-color pipe-color))
+ (vl-append
+ 4
+ (colorize (box #:inset 2 (text "REPL 1"))
+ tcp-color)
+ (colorize (box #:inset 2 (text "REPL 2"))
+ tcp-color)
+ (colorize (box #:inset 2
+ #:segment 2
+ (text "REPL n" '(italic)))
+ tcp-color))))))
+
+(define (back-end-source-files)
+ (box
+ #:outset 2
+ #:inset 2
+ #:color (light "gray")
+ #:background (light "gray")
+ (text "/tmp/racket-mode-back-end/*.rkt" 'modern 10)))
+
+(define (host name . paths)
+ (box
+ #:inset 5
+ #:color "gray"
+ #:width 2
+ #:background host-color
+ (vc-append
+ 5
+ (box #:inset 2
+ #:background "black"
+ (colorize (text name '(bold . modern) 14) "white"))
+ (if (equal? name "localhost")
+ (front-end)
+ (back-end-source-files))
+ (inset (apply hc-append 10 (map backend paths))
+ 5))))
+
+;; (host "localhost" "/")
+;; (host "localhost" "/" "/path/to/project")
+
+(define (scenario local . remotes)
+ (inset
+ (ht-append
+ 10
+ (apply host local)
+ (apply vl-append
+ 10
+ (for/list ([remote remotes])
+ (apply host remote))))
+ 10))
+
+(define images
+ (list
+ (scenario '("localhost" "/"))
+ (scenario '("localhost" "/" "/path/to/project/"))
+ (scenario '("localhost" "/" "/path/to/project/")
+ '("remote" "/user@remote:/"))
+ (scenario '("localhost" "/" "/path/to/project/")
+ '("remote" "/user@remote:/" "/user@remote:/path/"))
+ (scenario '("localhost" "/" "/path/to/project/")
+ '("alpha" "/user@alpha:/" "/user@alpha:/path/")
+ '("bravo" "/user@bravo:/" "/user@bravo:/path/"))))
+
+(module+ interactive
+ images)
+
+(module+ main
+ (require file/convertible)
+ (for ([(image n) (in-indexed images)])
+ (with-output-to-file
+ (format "scenario-~a.svg" n)
+ #:exists 'replace
+ #:mode 'binary (λ () (display (convert image 'svg-bytes))))))
diff --git a/doc/generate.el b/doc/generate.el
index c024841..70aa0bc 100644
--- a/doc/generate.el
+++ b/doc/generate.el
@@ -1,16 +1,7 @@
;;; generate.el -*- lexical-binding: t -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
-
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Generate a reference.org file from doc strings
@@ -28,17 +19,18 @@
(require 'racket-unicode-input-method)
(require 'racket-smart-open)
(require 'racket-repl-buffer-name)
-(require 'cl-lib)
+(require 'seq)
(defun racket-generate-reference.org ()
(find-file "reference.org")
(delete-region (point-min) (point-max))
(insert (racket-generate--commands))
(insert (racket-generate--variables))
+ (insert (racket-generate--configuration-functions))
(insert (racket-generate--faces))
(save-buffer 0)) ;don't create reference.org~ backup
-;;; Commands
+;;; Interactive command functions
(defconst racket-generate--commands
`("Edit"
@@ -74,7 +66,7 @@
(racket-xp-tail-next-sibling ,racket-xp-mode-map)
(racket-xp-tail-previous-sibling ,racket-xp-mode-map)
racket-documentation-search
- racket-search-describe
+ racket-describe-search
"Run"
racket-repl-mode
racket-run
@@ -100,7 +92,6 @@
racket-send-last-sexp
"Collections"
racket-open-require-path
- racket-find-collection
"Macro expand"
racket-stepper-mode
racket-expand-file
@@ -108,9 +99,43 @@
racket-expand-definition
racket-expand-last-sexp
"Other"
+ racket-debug-toggle-breakpoint
racket-mode-start-faster
- racket-mode-start-slower
- "Showing information"
+ racket-mode-start-slower)
+ "Commands to include in the Reference.")
+
+(defun racket-generate--commands ()
+ (apply
+ #'concat
+ "* Commands\n\n"
+ (mapcar (lambda (s)
+ (pcase s
+ ((and str (pred stringp))
+ (format "** %s\n\n" s))
+ ((and sym (pred symbolp))
+ (racket-generate--command-or-function sym racket-mode-map))
+ (`(,sym ,keymap)
+ (racket-generate--command-or-function sym keymap))))
+ racket-generate--commands)))
+
+(defun racket-generate--command-or-function (sym keymap)
+ (unless (fboundp sym)
+ (error "not defined %s" sym))
+ (concat (format "*** %s\n" sym)
+ (if keymap
+ (when (interactive-form sym)
+ (racket-generate--bindings-as-kbd sym keymap))
+ (format "~%s~\n" (cons sym (help-function-arglist sym))))
+ "\n\n"
+ (racket-generate--format-doc-string
+ (or (documentation sym t)
+ "No documentation.\n\n"))
+ "\n\n"))
+
+;;; Configuration functions
+
+(defconst racket-generate--configuration-functions
+ `("Showing information"
racket-show-pseudo-tooltip
racket-show-echo-area
racket-show-header-line
@@ -121,39 +146,27 @@
racket-repl-buffer-name-project
racket-project-root
"Browsing file URLs with anchors"
- racket-browse-url-using-temporary-file)
- "Commands to include in the Reference.")
-
-(defun racket-generate--commands ()
- (apply #'concat
- (cons "* Commands\n\n"
- (mapcar #'racket-generate--command racket-generate--commands))))
+ racket-browse-url-using-temporary-file
+ "Configuring back ends"
+ racket-add-back-end
+ "Running racket and raco commands in a shell or terminal"
+ racket-shell
+ racket-term
+ racket-ansi-term
+ racket-vterm)
+ "Configuration functions to include in the Reference.")
-(defun racket-generate--command (s)
- (pcase s
- ((and str (pred stringp))
- (format "** %s\n\n" s))
- ((and sym (pred symbolp))
- (racket-generate--command-2 sym racket-mode-map))
- (`(,sym ,keymap)
- (racket-generate--command-2 sym keymap))))
-
-(defun racket-generate--command-2 (sym keymap)
- (unless (fboundp sym)
- (error "not defined %s" sym))
- (concat (format "*** %s\n" sym)
- (and (interactive-form sym)
- (racket-generate--bindings-as-kbd sym keymap))
- "\n\n"
- (racket-generate--quotes-to-tildes
- (racket-generate--linkify
- (racket-generate--bracket-command
- keymap
- (racket-generate--angle-mapvar
- (racket-generate--braces-mapvar
- (or (documentation sym t)
- "No documentation.\n\n"))))))
- "\n\n"))
+(defun racket-generate--configuration-functions ()
+ (apply
+ #'concat
+ "* Configuration functions\n\n"
+ (mapcar (lambda (s)
+ (pcase s
+ ((and str (pred stringp))
+ (format "** %s\n\n" s))
+ ((and sym (pred symbolp))
+ (racket-generate--command-or-function sym nil))))
+ racket-generate--configuration-functions)))
;;; Variables
@@ -164,8 +177,6 @@
racket-memory-limit
racket-error-context
racket-user-command-line-arguments
- racket-path-from-emacs-to-racket-function
- racket-path-from-racket-to-emacs-function
racket-browse-url-function
racket-xp-after-change-refresh-delay
racket-xp-highlight-unused-regexp
@@ -188,41 +199,42 @@
racket-logger-config
racket-before-run-hook
racket-after-run-hook
+ racket-sexp-comment-fade
"Experimental debugger variables"
racket-debuggable-files
"Showing information"
- racket-show-functions)
+ racket-show-functions
+ "Running racket and raco commands in a shell or terminal"
+ racket-shell-or-terminal-function)
"Variables to include in the Reference.")
(defun racket-generate--variables ()
- (apply #'concat
- (cons "* Variables\n\n"
- (mapcar #'racket-generate--variable racket-generate--variables))))
-
-(defun racket-generate--variable (s)
- (if (stringp s)
- (format "** %s\n\n" s)
- (unless (boundp s)
- (error "variable does not exist: %s" s))
- (concat (format "*** %s\n" s)
- (racket-generate--quotes-to-tildes
- (racket-generate--linkify
- (racket-generate--bracket-command
- racket-mode-map
- (racket-generate--angle-mapvar
- (or (documentation-property s 'variable-documentation t)
- ;; Do check for function documentation here, to
- ;; support documenting values for `-functions'
- ;; variables.
- (documentation s t)
- "No documentation.\n\n")))))
- "\n\n")))
+ (apply
+ #'concat
+ "* Variables\n\n"
+ (mapcar (lambda (s)
+ (if (stringp s)
+ (format "** %s\n\n" s)
+ (unless (boundp s)
+ (error "variable does not exist: %s" s))
+ (concat
+ (format "*** %s\n" s)
+ (racket-generate--format-doc-string
+ (or (documentation-property s 'variable-documentation t)
+ ;; Do check for function documentation here,
+ ;; to support documenting values for
+ ;; `-functions' variables.
+ (documentation s t)
+ "No documentation.\n\n"))
+ "\n\n")))
+ racket-generate--variables)))
;;; Faces
(defconst racket-generate--faces
'(racket-keyword-argument-face
- racket-selfeval-face
+ racket-reader-quoted-symbol-face
+ racket-reader-syntax-quoted-symbol-face
racket-here-string-face
racket-xp-def-face
racket-xp-use-face
@@ -235,92 +247,102 @@
racket-logger-error-face
racket-logger-warning-face
racket-logger-info-face
- racket-logger-debug-face)
+ racket-logger-debug-face
+ racket-doc-link-face
+ racket-ext-link-face
+ racket-doc-output-face
+ racket-doc-litchar-face)
"Faces to include in the Reference.")
(defun racket-generate--faces ()
- (apply #'concat
- (cl-list* "* Faces\n\n"
- "** All\n\n"
- (mapcar #'racket-generate--face racket-generate--faces))))
-
-(defun racket-generate--face (symbol)
- (concat (format "*** %s\n" symbol)
- (racket-generate--quotes-to-tildes
- (racket-generate--linkify
- (or (documentation-property symbol 'face-documentation t)
- "No documentation.\n\n")))
- "\n\n"))
+ (apply
+ #'concat
+ "* Faces\n\n"
+ "** All\n\n"
+ (mapcar (lambda (symbol)
+ (concat
+ (format "*** %s\n" symbol)
+ (racket-generate--format-doc-string
+ (or (documentation-property symbol 'face-documentation t)
+ "No documentation.\n\n"))
+ "\n\n"))
+ racket-generate--faces)))
;;; Utility
-(defun racket-generate--linkify (s)
- (with-temp-buffer
- (insert s)
- (goto-char (point-min))
- (while (re-search-forward (rx ?\`
- (group "racket-" (+ (or (syntax word)
- (syntax symbol))))
- ?\')
- nil t)
- (let* ((name (match-string-no-properties 1))
- (sym (intern-soft name)))
- (when (or (cl-some (lambda (v)
- (or (eq v sym)
- (and (listp v)
- (eq (car v) sym))))
- racket-generate--commands)
- (member sym racket-generate--variables)
- (member sym racket-generate--faces))
- (replace-match (format "@@texinfo:@ref{%s}@@" name)
- t t))))
- (buffer-substring-no-properties (point-min) (point-max))))
+(defun racket-generate--format-doc-string (docstring)
+ "Convert command key references and keymap references
+in DOCSTRING to buttons.
-(defun racket-generate--quotes-to-tildes (s)
- "Change \` \' and \` \` style quotes to ~~ style."
- (with-temp-buffer
- (insert s)
- (goto-char (point-min))
- (while (re-search-forward (rx (or (seq ?\`
- (group (+? any
- ;; (or (syntax word)
- ;; (syntax symbol)
- ;; ?\# ?\'
- ;; (syntax whitespace)
- ))
- (or ?\` ?\'))))
- nil t)
- (let ((name (match-string-no-properties 1)))
- (replace-match (format "~%s~" name)
- t t)))
- (buffer-substring-no-properties (point-min) (point-max))))
-
-;;(racket-generate--quotes-to-tildes "foo `bar` bazz")
-;;(racket-generate--quotes-to-tildes "foo `bar bazz`")
-;;(racket-generate--quotes-to-tildes "foo `'symbol`")
-;;(racket-generate--quotes-to-tildes "Change from `#lang racket` to `#lang racket/base`.")
-
-(defun racket-generate--braces-mapvar (s)
- ;; ‘\{MAPVAR}’ stands for a summary of the keymap which is the value
- ;; of the variable MAPVAR.
- (with-temp-buffer
- (insert s)
- (goto-char (point-min))
- (while (re-search-forward (rx (or (seq ?\\
- ?\{
- (group (+ (or (syntax word)
- (syntax symbol))))
- ?\})))
- nil t)
- (let* ((name (match-string-no-properties 1))
- (sym (intern-soft name))
- (km (symbol-value sym)))
- (replace-match "")
- (insert "|Key|Binding|\n")
- (mapc #'racket-generate--insert-keymap-table-row
- (cdr km))
- (newline)))
- (buffer-substring-no-properties (point-min) (point-max))))
+Emacs uses \\= to escape \\[ references, so replace that
+unescaping too."
+ ;; Based on helpful--format-command-keys, which in turn is loosely
+ ;; based on `substitute-command-keys'.
+ (let ((keymap nil))
+ (with-temp-buffer
+ (insert docstring)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond
+ ((looking-at
+ ;; Text of the form \=X
+ (rx "\\="))
+ ;; Remove the escaping, then step over the escaped char.
+ (delete-region (point) (+ (point) 2))
+ (forward-char 1))
+ ((looking-at
+ ;; Text of the form `racket-XXX'
+ (rx "`" (group "racket-" (+ (or (syntax word) (syntax symbol)))) "'"))
+ (let* ((len (length (match-string 0)))
+ (name (match-string-no-properties 1))
+ (sym (intern-soft name)))
+ (delete-region (point) (+ (point) len))
+ (insert (racket-generate--ref-or-code sym))))
+ ((looking-at
+ ;; Text of the form `contents' or `contents`
+ (rx "`" (group (+ (not (in "`'")))) (in "`'")))
+ (let* ((len (length (match-string 0)))
+ (contents (match-string 1)))
+ (delete-region (point) (+ (point) len))
+ (insert (format "~%s~" contents))))
+ ((looking-at
+ ;; Text of the form \\<foo-keymap>
+ (rx "\\<" (group (+ (not (in ">")))) ">"
+ (? "\n")))
+ (let* ((len (length (match-string 0)))
+ (symbol-name (match-string 1)))
+ ;; Remove the original string.
+ (delete-region (point) (+ (point) len))
+ ;; Set the new keymap.
+ (setq keymap (symbol-value (intern symbol-name)))))
+ ((looking-at
+ ;; Text of the form \\{foo-mode-map}
+ (rx "\\{" (group (+ (not (in "}")))) "}"))
+ (let ((len (length (match-string 0)))
+ (km (symbol-value (intern (match-string 1)))))
+ ;; Remove the original string.
+ (delete-region (point) (+ (point) len))
+ ;; Insert an org-mode table
+ (when km
+ (insert "|Key|Binding|\n")
+ (mapc #'racket-generate--insert-keymap-table-row
+ (cdr km))
+ (newline))))
+ ((looking-at
+ ;; Text of the form \\[foo-command]
+ (rx "\\[" (group (+ (not (in "]")))) "]"))
+ (let* ((len (length (match-string 0)))
+ (name (match-string 1)))
+ ;; Remove the original string.
+ (delete-region (point) (+ (point) len))
+ (insert
+ (if (string-equal name "universal-argument")
+ "{{{kbd(C-u)}}}"
+ (racket-generate--bindings-as-kbd (intern-soft name) keymap)))))
+ ;; Don't modify other characters.
+ (t
+ (forward-char 1))))
+ (buffer-string))))
(defun racket-generate--insert-keymap-table-row (v &optional keys)
(pcase v
@@ -331,10 +353,9 @@
(racket-generate--insert-keymap-table-row v (cons key keys)))
more))
(`(,(and key (pred numberp)) . ,(and sym (pred symbolp)))
- (insert (format "|{{{kbd(%s)}}}|`%s'|\n"
- (racket-generate--key-description
- (reverse (cons key keys)))
- sym)))))
+ (insert (format "|{{{kbd(%s)}}}|%s|\n"
+ (racket-generate--key-description (reverse (cons key keys)))
+ (racket-generate--ref-or-code sym))))))
(defun racket-generate--key-description (xs)
"Like `key-description' but escapes some chars for our \"KBD\" texi macro."
@@ -346,50 +367,14 @@
(replace-match "")
(insert (if (equal str "}") "@" "\\"))
(insert str)))
- (buffer-substring-no-properties (point-min) (point-max))))
-
-(defun racket-generate--angle-mapvar (s)
- ;; \\<MAPVAR> stands for no text itself. It is used only for a side
- ;; effect: it specifies MAPVAR’s value as the keymap for any
- ;; following ‘\[COMMAND]’ sequences in this documentation string.
- (with-temp-buffer
- (insert s)
- (goto-char (point-min))
- (while (re-search-forward (rx (or (seq ?\\
- ?\<
- (group (+ (or (syntax word)
- (syntax symbol))))
- ?\>)))
- nil t)
- (replace-match ""))
- (buffer-substring-no-properties (point-min) (point-max))))
-
-(defun racket-generate--bracket-command (keymap str)
- ;; \\[COMMAND] stands for a key sequence that will invoke COMMAND,
- ;; or ‘M-x COMMAND’ if COMMAND has no key bindings.
- (with-temp-buffer
- (insert str)
- (goto-char (point-min))
- (while (re-search-forward (rx (or (seq ?\\
- ?\[
- (group (+ (or (syntax word)
- (syntax symbol))))
- ?\])))
- nil t)
- (let ((name (match-string-no-properties 1)))
- (replace-match "")
- (insert
- (if (string-equal name "universal-argument")
- "{{{kbd(C-u)}}}"
- (racket-generate--bindings-as-kbd (intern-soft name) keymap)))))
- (buffer-substring-no-properties (point-min) (point-max))))
+ (buffer-string)))
(defun racket-generate--bindings-as-kbd (symbol keymap)
- (let* ((bindings (or (racket-generate--where-is-no-menu symbol keymap)
- (racket-generate--where-is-no-menu symbol racket-mode-map)))
+ (let* ((bindings (or (racket-generate--where-is/no-menu symbol keymap)
+ (racket-generate--where-is/no-menu symbol racket-mode-map)))
(strs (and
bindings
- (cl-remove-if-not
+ (seq-filter
#'identity
(mapcar (lambda (binding)
(let ((desc (racket-generate--key-description binding)))
@@ -399,11 +384,24 @@
(format "{{{kbd(%s)}}}" desc))))
bindings)))))
(if strs
- (mapconcat #'identity strs " or ")
+ (string-join strs " or ")
(format "{{{kbd(M-x)}}} ~%s~" symbol))))
-(defun racket-generate--where-is-no-menu (symbol keymap)
- (cl-remove-if (lambda (binding) (eq (aref binding 0) 'menu-bar))
- (where-is-internal symbol keymap)))
+(defun racket-generate--where-is/no-menu (symbol keymap)
+ (seq-filter (lambda (binding) (not (eq (aref binding 0) 'menu-bar)))
+ (where-is-internal symbol keymap)))
+
+(defun racket-generate--ref-or-code (sym)
+ "Return either a reference or code formatting for SYM."
+ (if (or (seq-some (lambda (v)
+ (or (eq v sym)
+ (and (listp v)
+ (eq (car v) sym))))
+ racket-generate--commands)
+ (member sym racket-generate--configuration-functions)
+ (member sym racket-generate--variables)
+ (member sym racket-generate--faces))
+ (format "@@texinfo:@ref{%s}@@" sym)
+ (format "~%s~" sym)))
;;; generate.el ends here
diff --git a/doc/racket-mode.org b/doc/racket-mode.org
index 19f0952..1363215 100644
--- a/doc/racket-mode.org
+++ b/doc/racket-mode.org
@@ -1,12 +1,13 @@
#+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: ref @@texinfo:@ref{$1}@@
#+MACRO: see @@texinfo:@xref{$1}@@
#+TITLE: Racket Mode
#+AUTHOR: Greg Hendershott
-#+EMAIL: racket@greghendershott.com
+#+EMAIL: racket-mode-author@greghendershott.com
#+LANGUAGE: en
#+TEXINFO_FILENAME: racket-mode.info
@@ -18,6 +19,15 @@
#+TEXINFO_PRINTED_TITLE: Racket Mode
+* Copying
+:PROPERTIES:
+:COPYING: t
+:END:
+
+Copyright (C) 2013-2022 by Greg Hendershott.
+
+SPDX-License-Identifier: GPL-3.0-or-later
+
* Introduction
The [[https://www.racket-mode.com/][Racket Mode]] package consists of a variety of Emacs major and minor modes, including:
@@ -33,21 +43,27 @@ The [[https://www.racket-mode.com/][Racket Mode]] package consists of a variety
- {{{ref(racket-profile-mode)}}}
- {{{ref(racket-debug-mode)}}}
-Racket Mode uses a "back end server" written in Racket, which is responsible for running files and implementing commands that cannot be implemented in Emacs Lisp.[fn:pkg]
-
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]].
-[fn:pkg] Racket Mode's Racket code is also delivered as part of the Emacs package --- /not/ as a Racket package. Delivering both Emacs and Racket code in one Emacs package simplifies installation and updates. The main drawback is that the Racket code is not automatically byte-compiled, as would normally be done by ~raco pkg install~. To address this: {{{see(racket-mode-start-faster)}}}.
+* Install, Update, and Uninstall
+
+The most common way to use Racket Mode is to install from a package archive like MELPA or NonGNU ELPA.
+
+Some people also use a system like [[https://github.com/radian-software/straight.el][straight.el]].
+
+Note that Racket Mode is only available on MELPA (/not/ "MELPA Stable"), and is available as a "rolling release" from NonGNU ELPA.
-* Install
+** Use Emacs 28.1 or newer with NonGNU ELPA
-The recommended way to use Racket Mode is to install the package from [[https://melpa.org/#/racket-mode][MELPA]].
+Emacs 28.1 or newer comes configured to use [[https://elpa.nongnu.org][NonGNU ELPA]], in which case you can skip ahead to [[Install]].
+
+With older versions of Emacs, you can use MELPA.
** Configure Emacs to use MELPA
-To use MELPA:
+Following is a quick guide that may work for you. (For definitive instructions and the latest trouble-shooting tips, please see https://melpa.org/#/getting-started.)
- Add the following to your =~/.emacs= or =~/.emacs.d/init.el=:
@@ -56,24 +72,47 @@ To use MELPA:
(add-to-list 'package-archives
'("melpa" . "https://melpa.org/packages/")
t)
+(package-initialize)
#+END_SRC
- Restart Emacs.
-- Type {{{kbd(M-x)}}} ~package-refresh-contents~ {{{kbd(RET)}}}.
+#+BEGIN_QUOTE
+NOTE: If you ever get an error message about "contacting a host" or "downloading an archive", the problem is not unique to Racket Mode. Please see https://melpa.org/#/getting-started.
+#+END_QUOTE
+
+** Install
+
+When Emacs is configured to use NonGNU ELPA or MELPA:
-** Install Racket Mode
+1. Type {{{kbd(M-x)}}} ~package-initialize~ {{{kbd(RET)}}}.
-When Emacs is configured to use MELPA, simply type {{{kbd(M-x)}}} ~package-install~ {{{kbd(RET)}}} ~racket-mode~ {{{kbd(RET)}}}.
+2. Type {{{kbd(M-x)}}} ~package-refresh-contents~ {{{kbd(RET)}}}.
+
+3. Type {{{kbd(M-x)}}} ~package-install~ {{{kbd(RET)}}} ~racket-mode~ {{{kbd(RET)}}}.
+
+#+BEGIN_QUOTE
+NOTE: If you get an error message about "contacting a host" or "downloading an archive", the problem is not unique to Racket Mode. Please see https://melpa.org/#/getting-started.
+#+END_QUOTE
** Minimal Racket
-If you have installed the minimal Racket distribution (for example by using the [[https://github.com/Homebrew/homebrew-core/blob/master/Formula/minimal-racket.rb][homebrew formula]]) Racket Mode needs some additional packages (like ~errortrace~ and ~macro-debugger~). A simple way to get all these packages is to install the ~drracket~ Racket package. In a command shell:
+If you have installed the minimal Racket distribution (for example by using the [[https://github.com/Homebrew/homebrew-core/blob/master/Formula/minimal-racket.rb][homebrew formula]]) Racket Mode needs some additional Racket packages. A simple way to get all these packages is to install the ~drracket~ Racket package. In a command shell:
+
+#+BEGIN_SRC shell
+raco pkg install --auto drracket
+#+END_SRC
+
+A more-targeted approach is instead to install these specific packages and their dependencies:
#+BEGIN_SRC shell
-raco pkg install drracket
+raco pkg install --auto data-lib errortrace-lib macro-debugger-text-lib rackunit-lib racket-index scribble-lib drracket-tool-text-lib
#+END_SRC
+If you do /not/ want to use ~racket-xp-mode~, then you can omit ~drracket-tool-text-lib~.
+
+On a headless server, you might want to omit ~gui-lib~. Unfortunately, ~racket-doc~ depends on ~gui-lib~. On the one hand, if you uninstall ~racket-doc~ and ~gui-lib~, you will no longer be able to access documentation when using a Racket Mode back end running there. On the other hand, if you leave ~gui-lib~ installed, you should be careful to run the Racket Mode back end using ~xvfb-run racket~.
+
** Uninstall
To uninstall Racket Mode, simply type {{{kbd(M-x)}}} ~package-delete~ {{{kbd(RET)}}} ~racket-mode~ {{{kbd(RET)}}}.
@@ -86,13 +125,21 @@ You should probably also exit and restart Emacs.
The "easy path" provided by Emacs is to update /all/ packages to their latest versions. Although you might not want to do this --- see next section --- here is how to do so:
-1. Use {{{kbd(M-x)}}} ~list-packages~. It should display a message like "42 packages can be upgraded; type ‘U’ to mark them for upgrading.".
+0. Use {{{kbd(M-x)}}} ~package-initialize~.
+
+1. Use {{{kbd(M-x)}}} ~package-refresh-contents~.
+
+2. Use {{{kbd(M-x)}}} ~list-packages~. It should display a message like "42 packages can be upgraded; type ‘U’ to mark them for upgrading.".
-2. Press {{{kbd(U)}}} as suggested to mark them all.
+3. Press {{{kbd(U)}}} as suggested to mark them all.
-3. Press {{{kbd(x)}}} to execute.
+4. Press {{{kbd(x)}}} to execute.
-After such a mass update, it might be wise to exist restart Emacs.
+After such a mass update, it might be wise to exit and restart Emacs.
+
+#+BEGIN_QUOTE
+NOTE: If you get an error message about "contacting a host" or "downloading an archive", the problem is not unique to Racket Mode. Please see https://melpa.org/#/getting-started.
+#+END_QUOTE
*** Updating just Racket Mode
@@ -100,11 +147,11 @@ Updating all packages sometimes is more than you want. For example, maybe you wi
To update just Racket Mode:
-1. Uninstall Racket Mode: {{{kbd(M-x)}}} ~package-delete~ {{{kbd(RET)}}} ~racket-mode~ {{{kbd(RET)}}}.
+1. {{{ref(Uninstall)}}}.
2. Optional but most reliable: Exit and restart Emacs.
-3. Install Racket Mode: {{{kbd(M-x)}}} ~package-install~ {{{kbd(RET)}}} ~racket-mode~ {{{kbd(RET)}}}. This will install the latest version.
+3. {{{ref(Install)}}} again. This will install the latest version.
* Configure
@@ -142,13 +189,13 @@ Racket Mode supports four, increasing levels of font-lock:
- ~2~: Identifiers in ~define~-like and ~let~-like forms.
- ~3~: Identifiers provided by ~racket~, ~typed/racket~, ~racket/syntax~, and ~syntax/parse~. (This level effectively treats Racket as a language, instead of a language for making languages.).
-** Completion
+** Completion at point
In Emacs, a major mode may supply a "completion-at-point function". This function is used by manual completion commands like ~complete-symbol~ (bound by default to {{{kbd(C-M-i)}}}), as well as by auto-completion packages like ~company-mode~.
- ~racket-mode~ supplies ~racket-complete-at-point~, which simply supplies the same symbols that it knows how to font-lock. This does /not/ require the Racket Mode back end to be running. But of course the completion candidates do not correspond to your program's definitions or those it imports. This is a static, "better than nothing" fallback.
-- ~racket-xp-mode~ --- an optional minor mode that enhances ~racket-mode~ --- supplies ~racket-xp-complete-at-point~, which uses a static analysis to find local and imported binding names. Although this requires the Racket Mode back end to be running --- and will automatically start it --- it does /not/ require the edit buffer to be ~racket-run~.
+- ~racket-xp-mode~ --- an optional minor mode that enhances ~racket-mode~ --- supplies ~racket-xp-complete-at-point~, which uses a static analysis to find local and imported binding names. Although this requires the Racket Mode back end to be running --- and will automatically start it --- it does /not/ require the edit buffer to be ~racket-run~. This also supplies meta data usable by the ~company-capf~ backend.
- ~racket-repl-mode~ supplies ~racket-repl-complete-at-point~, which uses the result of ~namespace-mapped-symbols~ on the program currently running in the REPL.
@@ -162,6 +209,12 @@ If you want {{{kbd(TAB)}}} to do completion as well as indent, add the following
This changes the behavior of Emacs' standard ~indent-for-tab-command~, to which {{{kbd(TAB)}}} is bound by default in ~racket-mode~ and ~racket-repl-mode~.
+** Completion in minibuffer
+
+Sometimes Racket Mode asks for input in the minibuffer. To do so it uses the standard Emacs function ~completing-read~, so as to be compatible with all Emacs packages that enhance ~completing-read~, such as helm, ivy, ido-completing-read+, vertico, and so on.
+
+(Earlier versions of Racket Mode sometimes used ~ido-completing-read~. If you have upgraded Racket Mode and miss that, simply install the ido-completing-read+ package.)
+
** Xref (definitions and references)
Several modes support the Emacs commands
@@ -198,6 +251,8 @@ In any case, using the Emacs xref API allows for consistent command names, short
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
If you use [[https://melpa.org/#/paredit][paredit]], you might want to add keybindings to ~paredit-mode-map~:
@@ -225,6 +280,15 @@ For example, with [[https://melpa.org/#/use-package][~use-package~]]:
("M-{" . paredit-wrap-curly))))
#+END_SRC
+Starting c. November 2022, paredit binds the {{{kbd(RET)}}} key to its own command. Unfortunately this is /not/ compatible with interactive modes --- including but not limited to ~racket-repl-mode~ --- which expect {{{kbd(RET)}}} to be bound to a command to submit your input to the REPL. In other words, if you type an expression and hit {{{kbd(RET)}}}, nothing will happen and the REPL will seem frozen. You ~M-x racket-repl-submit~ to proceed.
+
+If you want to use paredit with interactive modes, their advice is to remove the binding from ~paredit-mode-map~ (note that this will also disable it for all buffers, including editing buffers). One way you can do this for all related keys:
+
+#+BEGIN_SRC lisp
+(dolist (k '("RET" "C-m" "C-j"))
+ (define-key paredit-mode-map (kbd k) nil))
+#+END_SRC
+
** smartparens
If instead of paredit you prefer [[https://melpa.org/#/smartparens][smartparens]], you can use the default configuration it provides for Lisp modes generally and for Racket Mode specifically:
@@ -233,6 +297,12 @@ If instead of paredit you prefer [[https://melpa.org/#/smartparens][smartparens]
(require 'smartparens-config)
#+END_SRC
+** Appearance of parentheses
+
+If you prefer parentheses to appear "dimmed", see [[https://melpa.org/#/paren-face][paren-face]].
+
+If you prefer the opposite, see [[https://melpa.org/#/rainbow-delimiters][rainbow-delimiters]].
+
** Edit buffers and REPL buffers
By default, all ~racket-mode~ edit buffers share one ~racket-repl-mode~ buffer, named ~*Racket REPL*~. For example, if you run foo.rkt, the REPL prompt changes to ~foo.rkt>~, and the REPL is inside the file module namespace. If you then run bar.rkt, the REPL prompt changes to ~bar.rkt>~, and you are in that namespace.
@@ -287,7 +357,44 @@ To automatically enable the ~racket-unicode~ input method in ~racket-mode~ and ~
** Ligatures
-Prior to Emacs 28.0.50, things like ~auto-composition-mode~ or ~ligature-mode~ that use ~composition-function-table~ to display ligatures can cause Emacs to freeze. This can happen when an Emacs ~overlay~ displays a string containing such a ligature --- this includes the overlays created by ~racket-show-pseudo-tooltip~, as used by ~racket-xp-mode~. The only known work-around is to change the value of ~racket-show-functions~ to something "boring" such as ~(racket-show-echo-area)~.
+Prior to Emacs 28.0.50, things like ~auto-composition-mode~ or ~ligature-mode~ that use ~composition-function-table~ to display ligatures can cause Emacs to freeze. This can happen when an Emacs /overlay/ displays a string containing such a ligature. Although the problem is not limited to Racket Mode, it affects the overlays created by ~racket-show-pseudo-tooltip~, as used by ~racket-xp-mode~. The only known work-around is to change the value of ~racket-show-functions~ to something "boring" such as ~(racket-show-echo-area)~.
+
+* Architecture
+Racket Mode consists of a single Emacs front end, and one or more processes running a back end written in Racket.[fn:pkg]
+
+A back end is responsible for commands that cannot be implemented in Emacs Lisp, as well as supplying zero or more REPLs.
+
+Although you can start and stop a back end with ~racket-start-back-end~ and ~racket-stop-back-end~, a back end is normally started automatically when the front end needs to issue some command. This includes commands that do /not/ involve ~racket-run~ or a REPL. For example ~racket-xp-mode~ issues commands to check your code and annotate the buffer, even if you do not run it. In other words, a back end supplies zero or more REPLs --- a back end is not the same thing as a REPL.
+
+To learn more about how /many/ REPLs are used: {{{see(racket-repl-buffer-name-function)}}}.
+
+In the common case there is only one back end, on the same local host as Emacs, and it is used for ~.rkt~ files in any directory.
+
+{{{img(scenario-0, Emacs front end and one local back end)}}}
+
+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 ~racket-run~ use the desired version of Racket for a file, so will commands for documentation or visiting definitions.)
+
+{{{img(scenario-1, Emacs front end and two local back ends --- one for a project path)}}}
+
+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.
+
+{{{img(scenario-2, Emacs front end and a back end on a remote host)}}}
+
+Of course the remote can also use different back ends for different paths.
+
+{{{img(scenario-3, Emacs front end and two back ends on a remote host)}}}
+
+And of course you can have multiple remotes.
+
+{{{img(scenario-4, Emacs front end and two back ends each on two remote hosts)}}}
+
+If you need any of these "fancy" configurations: {{{see(racket-add-back-end)}}}.
+
+However by default a configuration is automatically created for one back end on the local host. For that very common case, you don't need to configure anything.
+
+[fn:pkg] Racket Mode's Racket code is delivered as part of the Emacs package --- /not/ as a Racket package. Delivering both Emacs and Racket code in one Emacs package simplifies installation and updates. The main drawback is that the Racket code is not automatically compiled, as would normally be done by ~raco pkg install~. To address this: {{{see(racket-mode-start-faster)}}}.
* Reference
diff --git a/doc/racket-mode.texi b/doc/racket-mode.texi
index f6083cf..21b7363 100644
--- a/doc/racket-mode.texi
+++ b/doc/racket-mode.texi
@@ -7,6 +7,13 @@
@syncodeindex pg cp
@c %**end of header
+@copying
+
+Copyright (C) 2013-2022 by Greg Hendershott.
+
+SPDX-License-Identifier: GPL-3.0-or-later
+@end copying
+
@dircategory Emacs
@direntry
* Racket Mode: (racket-mode). Edit and REPL major modes for Racket lang.
@@ -15,7 +22,10 @@
@finalout
@titlepage
@title Racket Mode
-@author Greg Hendershott (@email{racket@@greghendershott.com})
+@author Greg Hendershott (@email{racket-mode-author@@greghendershott.com})
+@page
+@vskip 0pt plus 1filll
+@insertcopying
@end titlepage
@contents
@@ -23,24 +33,28 @@
@ifnottex
@node Top
@top Racket Mode
+@insertcopying
@end ifnottex
@menu
* Introduction::
-* Install::
+* Install, Update, and Uninstall: Install Update and Uninstall.
* Configure::
+* Architecture::
* Reference::
* Commands::
* Variables::
+* Configuration functions::
* Faces::
@detailmenu
--- The Detailed Node Listing ---
-Install
+Install, Update, and Uninstall
+* Use Emacs 28.1 or newer with NonGNU ELPA: Use Emacs 281 or newer with NonGNU ELPA.
* Configure Emacs to use MELPA::
-* Install Racket Mode::
+* Install::
* Minimal Racket::
* Uninstall::
* Update::
@@ -53,11 +67,13 @@ Configure
* Key bindings::
* Font-lock (syntax highlighting)::
-* Completion::
+* Completion at point::
+* Completion in minibuffer::
* Xref (definitions and references)::
* Indent::
* paredit::
* smartparens::
+* Appearance of parentheses::
* Edit buffers and REPL buffers::
* eldoc::
* Start faster::
@@ -74,9 +90,6 @@ Commands
* Collections::
* Macro expand::
* Other::
-* Showing information::
-* Associating edit buffers with REPL buffers::
-* Browsing file URLs with anchors::
Edit
@@ -114,7 +127,7 @@ Explore
* racket-xp-tail-next-sibling::
* racket-xp-tail-previous-sibling::
* racket-documentation-search::
-* racket-search-describe::
+* racket-describe-search::
Run
@@ -148,7 +161,6 @@ Eval
Collections
* racket-open-require-path::
-* racket-find-collection::
Macro expand
@@ -160,33 +172,17 @@ Macro expand
Other
+* racket-debug-toggle-breakpoint::
* racket-mode-start-faster::
* racket-mode-start-slower::
-
-Showing information
-
-* racket-show-pseudo-tooltip::
-* racket-show-echo-area::
-* racket-show-header-line::
-* racket-show-pos-tip::
-
-Associating edit buffers with REPL buffers
-
-* racket-repl-buffer-name-shared::
-* racket-repl-buffer-name-unique::
-* racket-repl-buffer-name-project::
-* racket-project-root::
-
-Browsing file URLs with anchors
-
-* racket-browse-url-using-temporary-file::
Variables
* General variables::
* REPL variables::
* Other variables::
* Experimental debugger variables::
-* Showing information: Showing informationx.
+* Showing information::
+* Running racket and raco commands in a shell or terminal::
General variables
@@ -195,8 +191,6 @@ General variables
* racket-memory-limit::
* racket-error-context::
* racket-user-command-line-arguments::
-* racket-path-from-emacs-to-racket-function::
-* racket-path-from-racket-to-emacs-function::
* racket-browse-url-function::
* racket-xp-after-change-refresh-delay::
* racket-xp-highlight-unused-regexp::
@@ -223,6 +217,7 @@ Other variables
* racket-logger-config::
* racket-before-run-hook::
* racket-after-run-hook::
+* racket-sexp-comment-fade::
Experimental debugger variables
@@ -231,6 +226,46 @@ Experimental debugger variables
Showing information
* racket-show-functions::
+
+Running racket and raco commands in a shell or terminal
+
+* racket-shell-or-terminal-function::
+Configuration functions
+
+* Showing information: Showing informationx.
+* Associating edit buffers with REPL buffers::
+* Browsing file URLs with anchors::
+* Configuring back ends::
+* Running racket and raco commands in a shell or terminal: Running racket and raco commands in a shell or terminalx.
+
+Showing information
+
+* racket-show-pseudo-tooltip::
+* racket-show-echo-area::
+* racket-show-header-line::
+* racket-show-pos-tip::
+
+Associating edit buffers with REPL buffers
+
+* racket-repl-buffer-name-shared::
+* racket-repl-buffer-name-unique::
+* racket-repl-buffer-name-project::
+* racket-project-root::
+
+Browsing file URLs with anchors
+
+* racket-browse-url-using-temporary-file::
+
+Configuring back ends
+
+* racket-add-back-end::
+
+Running racket and raco commands in a shell or terminal
+
+* racket-shell::
+* racket-term::
+* racket-ansi-term::
+* racket-vterm::
Faces
* All::
@@ -238,7 +273,8 @@ Faces
All
* racket-keyword-argument-face::
-* racket-selfeval-face::
+* racket-reader-quoted-symbol-face::
+* racket-reader-syntax-quoted-symbol-face::
* racket-here-string-face::
* racket-xp-def-face::
* racket-xp-use-face::
@@ -252,6 +288,10 @@ All
* racket-logger-warning-face::
* racket-logger-info-face::
* racket-logger-debug-face::
+* racket-doc-link-face::
+* racket-ext-link-face::
+* racket-doc-output-face::
+* racket-doc-litchar-face::
@end detailmenu
@end menu
@@ -284,28 +324,38 @@ Various other modes to support specific features:
@end itemize
@end itemize
-Racket Mode uses a ``back end server'' written in Racket, which is responsible for running files and implementing commands that cannot be implemented in Emacs Lisp.@footnote{Racket Mode's Racket code is also delivered as part of the Emacs package --- @emph{not} as a Racket package. Delivering both Emacs and Racket code in one Emacs package simplifies installation and updates. The main drawback is that the Racket code is not automatically byte-compiled, as would normally be done by @code{raco pkg install}. To address this: @xref{racket-mode-start-faster}.}
-
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}.
-@node Install
-@chapter Install
+@node Install Update and Uninstall
+@chapter Install, Update, and Uninstall
+
+The most common way to use Racket Mode is to install from a package archive like MELPA or NonGNU ELPA.
+
+Some people also use a system like @uref{https://github.com/radian-software/straight.el,straight.el}.
-The recommended way to use Racket Mode is to install the package from @uref{https://melpa.org/#/racket-mode,MELPA}.
+Note that Racket Mode is only available on MELPA (@emph{not} ``MELPA Stable''), and is available as a ``rolling release'' from NonGNU ELPA.
@menu
+* Use Emacs 28.1 or newer with NonGNU ELPA: Use Emacs 281 or newer with NonGNU ELPA.
* Configure Emacs to use MELPA::
-* Install Racket Mode::
+* Install::
* Minimal Racket::
* Uninstall::
* Update::
@end menu
+@node Use Emacs 281 or newer with NonGNU ELPA
+@section Use Emacs 28.1 or newer with NonGNU ELPA
+
+Emacs 28.1 or newer comes configured to use @uref{https://elpa.nongnu.org,NonGNU ELPA}, in which case you can skip ahead to @ref{Install,Install}.
+
+With older versions of Emacs, you can use MELPA.
+
@node Configure Emacs to use MELPA
@section Configure Emacs to use MELPA
-To use MELPA:
+Following is a quick guide that may work for you. (For definitive instructions and the latest trouble-shooting tips, please see @uref{https://melpa.org/#/getting-started}.)
@itemize
@item
@@ -315,32 +365,59 @@ Add the following to your @verb{,~/.emacs,} or @verb{,~/.emacs.d/init.el,}:
@lisp
(require 'package)
(add-to-list 'package-archives
- '("melpa" . "https://melpa.org/packages/")
- t)
+ '("melpa" . "https://melpa.org/packages/")
+ t)
+(package-initialize)
@end lisp
@itemize
@item
Restart Emacs.
+@end itemize
+
+@quotation
+NOTE: If you ever get an error message about ``contacting a host'' or ``downloading an archive'', the problem is not unique to Racket Mode. Please see @uref{https://melpa.org/#/getting-started}.
+@end quotation
+
+@node Install
+@section Install
+
+When Emacs is configured to use NonGNU ELPA or MELPA:
+
+@enumerate
+@item
+Type @kbd{M-x} @code{package-initialize} @kbd{RET} .
@item
Type @kbd{M-x} @code{package-refresh-contents} @kbd{RET} .
-@end itemize
-@node Install Racket Mode
-@section Install Racket Mode
+@item
+Type @kbd{M-x} @code{package-install} @kbd{RET} @code{racket-mode} @kbd{RET} .
+@end enumerate
-When Emacs is configured to use MELPA, simply type @kbd{M-x} @code{package-install} @kbd{RET} @code{racket-mode} @kbd{RET} .
+@quotation
+NOTE: If you get an error message about ``contacting a host'' or ``downloading an archive'', the problem is not unique to Racket Mode. Please see @uref{https://melpa.org/#/getting-started}.
+@end quotation
@node Minimal Racket
@section Minimal Racket
-If you have installed the minimal Racket distribution (for example by using the @uref{https://github.com/Homebrew/homebrew-core/blob/master/Formula/minimal-racket.rb,homebrew formula}) Racket Mode needs some additional packages (like @code{errortrace} and @code{macro-debugger}). A simple way to get all these packages is to install the @code{drracket} Racket package. In a command shell:
+If you have installed the minimal Racket distribution (for example by using the @uref{https://github.com/Homebrew/homebrew-core/blob/master/Formula/minimal-racket.rb,homebrew formula}) Racket Mode needs some additional Racket packages. A simple way to get all these packages is to install the @code{drracket} Racket package. In a command shell:
+
+@example
+raco pkg install --auto drracket
+@end example
+
+A more-targeted approach is instead to install these specific packages and their dependencies:
@example
-raco pkg install drracket
+raco pkg install --auto data-lib errortrace-lib macro-debugger-text-lib rackunit-lib racket-index scribble-lib drracket-tool-text-lib
@end example
+If you do @emph{not} want to use @code{racket-xp-mode}, then you can omit @code{drracket-tool-text-lib}.
+
+On a headless server, you might want to omit @code{gui-lib}. Unfortunately, @code{racket-doc} depends on @code{gui-lib}. On the one hand, if you uninstall @code{racket-doc} and @code{gui-lib}, you will no longer be able to access documentation when using a Racket Mode back end running there. On the other hand, if you leave @code{gui-lib} installed, you should be careful to run the Racket Mode back end using @code{xvfb-run racket}.
+
@node Uninstall
@section Uninstall
@@ -362,6 +439,12 @@ You should probably also exit and restart Emacs.
The ``easy path'' provided by Emacs is to update @emph{all} packages to their latest versions. Although you might not want to do this --- see next section --- here is how to do so:
@enumerate
+@item
+Use @kbd{M-x} @code{package-initialize}.
+
+@item
+Use @kbd{M-x} @code{package-refresh-contents}.
+
@item
Use @kbd{M-x} @code{list-packages}. It should display a message like ``42 packages can be upgraded; type ‘U’ to mark them for upgrading.''.
@@ -372,7 +455,11 @@ Press @kbd{U} as suggested to mark them all.
Press @kbd{x} to execute.
@end enumerate
-After such a mass update, it might be wise to exist restart Emacs.
+After such a mass update, it might be wise to exit and restart Emacs.
+
+@quotation
+NOTE: If you get an error message about ``contacting a host'' or ``downloading an archive'', the problem is not unique to Racket Mode. Please see @uref{https://melpa.org/#/getting-started}.
+@end quotation
@node Updating just Racket Mode
@subsection Updating just Racket Mode
@@ -383,13 +470,13 @@ To update just Racket Mode:
@enumerate
@item
-Uninstall Racket Mode: @kbd{M-x} @code{package-delete} @kbd{RET} @code{racket-mode} @kbd{RET} .
+@ref{Uninstall}.
@item
Optional but most reliable: Exit and restart Emacs.
@item
-Install Racket Mode: @kbd{M-x} @code{package-install} @kbd{RET} @code{racket-mode} @kbd{RET} . This will install the latest version.
+@ref{Install} again. This will install the latest version.
@end enumerate
@node Configure
@@ -405,11 +492,13 @@ You can @code{setq} this directly in your Emacs init file (@verb{,~/.emacs,} or
@menu
* Key bindings::
* Font-lock (syntax highlighting)::
-* Completion::
+* Completion at point::
+* Completion in minibuffer::
* Xref (definitions and references)::
* Indent::
* paredit::
* smartparens::
+* Appearance of parentheses::
* Edit buffers and REPL buffers::
* eldoc::
* Start faster::
@@ -424,8 +513,8 @@ To customize things like key bindings, you can use @code{racket-mode-hook} in yo
@lisp
(add-hook 'racket-mode-hook
- (lambda ()
- (define-key racket-mode-map (kbd "<f5>") 'racket-run)))
+ (lambda ()
+ (define-key racket-mode-map (kbd "<f5>") 'racket-run)))
@end lisp
Likewise for @code{racket-repl-mode-hook} and @code{racket-repl-mode-map}.
@@ -450,8 +539,8 @@ Racket Mode supports four, increasing levels of font-lock:
@code{3}: Identifiers provided by @code{racket}, @code{typed/racket}, @code{racket/syntax}, and @code{syntax/parse}. (This level effectively treats Racket as a language, instead of a language for making languages.).
@end itemize
-@node Completion
-@section Completion
+@node Completion at point
+@section Completion at point
In Emacs, a major mode may supply a ``completion-at-point function''. This function is used by manual completion commands like @code{complete-symbol} (bound by default to @kbd{C-M-i} ), as well as by auto-completion packages like @code{company-mode}.
@@ -460,7 +549,7 @@ In Emacs, a major mode may supply a ``completion-at-point function''. This funct
@code{racket-mode} supplies @code{racket-complete-at-point}, which simply supplies the same symbols that it knows how to font-lock. This does @emph{not} require the Racket Mode back end to be running. But of course the completion candidates do not correspond to your program's definitions or those it imports. This is a static, ``better than nothing'' fallback.
@item
-@code{racket-xp-mode} --- an optional minor mode that enhances @code{racket-mode} --- supplies @code{racket-xp-complete-at-point}, which uses a static analysis to find local and imported binding names. Although this requires the Racket Mode back end to be running --- and will automatically start it --- it does @emph{not} require the edit buffer to be @code{racket-run}.
+@code{racket-xp-mode} --- an optional minor mode that enhances @code{racket-mode} --- supplies @code{racket-xp-complete-at-point}, which uses a static analysis to find local and imported binding names. Although this requires the Racket Mode back end to be running --- and will automatically start it --- it does @emph{not} require the edit buffer to be @code{racket-run}. This also supplies meta data usable by the @code{company-capf} backend.
@item
@code{racket-repl-mode} supplies @code{racket-repl-complete-at-point}, which uses the result of @code{namespace-mapped-symbols} on the program currently running in the REPL.
@@ -476,6 +565,13 @@ If you want @kbd{TAB} to do completion as well as indent, add the following to
This changes the behavior of Emacs' standard @code{indent-for-tab-command}, to which @kbd{TAB} is bound by default in @code{racket-mode} and @code{racket-repl-mode}.
+@node Completion in minibuffer
+@section Completion in minibuffer
+
+Sometimes Racket Mode asks for input in the minibuffer. To do so it uses the standard Emacs function @code{completing-read}, so as to be compatible with all Emacs packages that enhance @code{completing-read}, such as helm, ivy, ido-completing-read+, vertico, and so on.
+
+(Earlier versions of Racket Mode sometimes used @code{ido-completing-read}. If you have upgraded Racket Mode and miss that, simply install the ido-completing-read+ package.)
+
@node Xref (definitions and references)
@section Xref (definitions and references)
@@ -529,6 +625,8 @@ In any case, using the Emacs xref API allows for consistent command names, short
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}.)
+
@node paredit
@section paredit
@@ -549,16 +647,25 @@ For example, with @uref{https://melpa.org/#/use-package,@code{use-package}}:
:ensure t
:config
(dolist (m '(emacs-lisp-mode-hook
- racket-mode-hook
- racket-repl-mode-hook))
+ racket-mode-hook
+ racket-repl-mode-hook))
(add-hook m #'paredit-mode))
(bind-keys :map paredit-mode-map
- ("@{" . paredit-open-curly)
- ("@}" . paredit-close-curly))
+ ("@{" . paredit-open-curly)
+ ("@}" . paredit-close-curly))
(unless terminal-frame
(bind-keys :map paredit-mode-map
- ("M-[" . paredit-wrap-square)
- ("M-@{" . paredit-wrap-curly))))
+ ("M-[" . paredit-wrap-square)
+ ("M-@{" . paredit-wrap-curly))))
+@end lisp
+
+Starting c. November 2022, paredit binds the @kbd{RET} key to its own command. Unfortunately this is @emph{not} compatible with interactive modes --- including but not limited to @code{racket-repl-mode} --- which expect @kbd{RET} to be bound to a command to submit your input to the REPL. In other words, if you type an expression and hit @kbd{RET} , nothing will happen and the REPL will seem frozen. You @code{M-x racket-repl-submit} to proceed.
+
+If you want to use paredit with interactive modes, their advice is to remove the binding from @code{paredit-mode-map} (note that this will also disable it for all buffers, including editing buffers). One way you can do this for all related keys:
+
+@lisp
+(dolist (k '("RET" "C-m" "C-j"))
+ (define-key paredit-mode-map (kbd k) nil))
@end lisp
@node smartparens
@@ -570,6 +677,13 @@ If instead of paredit you prefer @uref{https://melpa.org/#/smartparens,smartpare
(require 'smartparens-config)
@end lisp
+@node Appearance of parentheses
+@section Appearance of parentheses
+
+If you prefer parentheses to appear ``dimmed'', see @uref{https://melpa.org/#/paren-face,paren-face}.
+
+If you prefer the opposite, see @uref{https://melpa.org/#/rainbow-delimiters,rainbow-delimiters}.
+
@node Edit buffers and REPL buffers
@section Edit buffers and REPL buffers
@@ -590,11 +704,11 @@ You can customize where the REPL buffer is displayed by adding an item to the Em
@lisp
(add-to-list 'display-buffer-alist
- '("\\`\\*Racket REPL"
- (display-buffer-reuse-window
- display-buffer-pop-up-frame)
- (reusable-frames . 0)
- (inhibit-same-window . t)))
+ '("\\`\\*Racket REPL"
+ (display-buffer-reuse-window
+ display-buffer-pop-up-frame)
+ (reusable-frames . 0)
+ (inhibit-same-window . t)))
@end lisp
@node eldoc
@@ -639,7 +753,44 @@ To automatically enable the @code{racket-unicode} input method in @code{racket-m
@node Ligatures
@section Ligatures
-Prior to Emacs 28.0.50, things like @code{auto-composition-mode} or @code{ligature-mode} that use @code{composition-function-table} to display ligatures can cause Emacs to freeze. This can happen when an Emacs @code{overlay} displays a string containing such a ligature --- this includes the overlays created by @code{racket-show-pseudo-tooltip}, as used by @code{racket-xp-mode}. The only known work-around is to change the value of @code{racket-show-functions} to something ``boring'' such as @code{(racket-show-echo-area)}.
+Prior to Emacs 28.0.50, things like @code{auto-composition-mode} or @code{ligature-mode} that use @code{composition-function-table} to display ligatures can cause Emacs to freeze. This can happen when an Emacs @emph{overlay} displays a string containing such a ligature. Although the problem is not limited to Racket Mode, it affects the overlays created by @code{racket-show-pseudo-tooltip}, as used by @code{racket-xp-mode}. The only known work-around is to change the value of @code{racket-show-functions} to something ``boring'' such as @code{(racket-show-echo-area)}.
+
+@node Architecture
+@chapter Architecture
+
+Racket Mode consists of a single Emacs front end, and one or more processes running a back end written in Racket.@footnote{Racket Mode's Racket code is delivered as part of the Emacs package --- @emph{not} as a Racket package. Delivering both Emacs and Racket code in one Emacs package simplifies installation and updates. The main drawback is that the Racket code is not automatically compiled, as would normally be done by @code{raco pkg install}. To address this: @xref{racket-mode-start-faster}.}
+
+A back end is responsible for commands that cannot be implemented in Emacs Lisp, as well as supplying zero or more REPLs.
+
+Although you can start and stop a back end with @code{racket-start-back-end} and @code{racket-stop-back-end}, a back end is normally started automatically when the front end needs to issue some command. This includes commands that do @emph{not} involve @code{racket-run} or a REPL. For example @code{racket-xp-mode} issues commands to check your code and annotate the buffer, even if you do not run it. In other words, a back end supplies zero or more REPLs --- a back end is not the same thing as a REPL.
+
+To learn more about how @emph{many} REPLs are used: @xref{racket-repl-buffer-name-function}.
+
+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}
+
+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}
+
+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}
+
+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}
+
+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}
+
+If you need any of these ``fancy'' configurations: @xref{racket-add-back-end}.
+
+However by default a configuration is automatically created for one back end on the local host. For that very common case, you don't need to configure anything.
@node Reference
@chapter Reference
@@ -667,9 +818,6 @@ You can also view these by using the normal Emacs help mechanism:
* Collections::
* Macro expand::
* Other::
-* Showing information::
-* Associating edit buffers with REPL buffers::
-* Browsing file URLs with anchors::
@end menu
@node Edit
@@ -725,6 +873,10 @@ Major mode for editing Racket source files.
@tab @ref{racket-unfold-all-tests}
@item @kbd{C-c C-f}
@tab @ref{racket-fold-all-tests}
+@item @kbd{C-c C-.}
+@tab @ref{racket-describe-search}
+@item @kbd{C-c C-s}
+@tab @ref{racket-describe-search}
@item @kbd{C-c C-d}
@tab @ref{racket-documentation-search}
@item @kbd{C-c C-p}
@@ -882,10 +1034,7 @@ Add a require for the identifier at point.
When more than one module supplies an identifer with the same
name, they are listed for you to choose one. The list is sorted
alphabetically, except modules starting with ``racket/'' and
-``typed/racket/'' are sorted before others. While at the prompt,
-as a convenience you can press C-h to see the ``Search Manuals''
-page for locally installed packages -- effectively like
-doing ``raco doc'' at the command line.
+``typed/racket/'' are sorted before others.
A ``require'' form is inserted into the buffer, followed by doing
a @ref{racket-tidy-requires}.
@@ -902,69 +1051,134 @@ identifiers that are exported but not documented.
Indent current line as Racket code.
-Normally you don't need to use this command directly, it is used
+Normally you don't invoke this command directly. Instead, because
+it is used as the value for the variable @code{indent-line-function}
+in @ref{racket-mode} and @ref{racket-repl-mode} buffers, it is used
automatically when you press keys like RET or TAB. However you
might refer to it when configuring custom indentation, explained
below.
-This behaves like @code{lisp-indent-line}, except that whole-line
-comments are treated the same regardless of whether they start
-with single or double semicolons.
+Following the tradition of @code{lisp-mode} and @code{scheme-mode}, the
+primary way to determine the indentation of a form is to look for
+a rule stored as a @code{racket-indent-function} property.
+
+To extend, use your Emacs init file to
+
+@lisp
+ (put SYMBOL 'racket-indent-function INDENT)
+@end lisp
+
+SYMBOL is the name of the Racket form like ``test-case'' and
+INDENT is an integer or the symbol ``defun''. When INDENT is an
+integer, the meaning is the same as for lisp-indent-function and
+scheme-indent-function: Indent the first INDENT arguments
+specially and indent any further arguments like a body. (The
+number may be negative; see discussion below.)
+
+For example:
+
+@lisp
+ (put 'test-case 'racket-indent-function 1)
+@end lisp
+
+This will change the indent of @code{test-case} from this:
+
+@example
+ (test-case foo
+ blah
+ blah)
+@end example
+
+to this:
+
+@example
+ (test-case foo
+ blah
+ blah)
+@end example
+
+For backward compatibility, if @code{racket-indent-function} has no
+property for a symbol, a scheme-indent-function property is also
+considered, although the ``with-'' indents defined by scheme-mode
+are ignored. This is only to help people who may have extensive
+scheme-indent-function settings, particularly in the form of file
+or dir local variables. Otherwise prefer putting properties on
+@code{racket-indent-function}.
+
+If no explicit rules match, regular expressions are used for a
+couple special cases:
@itemize
@item
-Automatically indents forms that start with ``begin'' in the
-usual way that ``begin'' is indented.
+Forms that start with ``begin'' indent like ``begin''.
@item
-Automatically indents forms that start with ``def'' or
-``with-'' in the usual way that ``define'' is indented.
+Forms that start with ``def'' or ``with-'' indent like
+``define''.
+@end itemize
+
+On the one hand this is convenient when you create your own
+``DRY'' macros; they will indent as expected without you needing
+to make custom indent rules. On the other hand there can be false
+matches; for example a function or form named ``defer'' will
+indent like ``define''. This is a known drawback and is unlikely
+to be fixed unless/until Racket macros someday support a protocol
+to communicate how they should be indented.
+
+There is also automatic handling for:
+@itemize
@item
-Has rules for many specific standard Racket forms.
-@end itemize
+Forms that begin with a #:keyword (as found in contracts)
-To extend, use your Emacs init file to
+@item
+Literal forms like #hasheq()
-@example
-(put SYMBOL 'racket-indent-function INDENT)
-@end example
+@item
+Quoted forms when the variable @ref{racket-indent-sequence-depth}
+ is > 0.
-SYMBOL is the name of the Racket form like ``'test-case'' and
-INDENT is an integer or the symbol ``'defun''. When INDENT is an
-integer, the meaning is the same as for lisp-indent-function and
-scheme-indent-function: Indent the first INDENT arguments
-specially and indent any further arguments like a body.
+@item
+@{@} forms when the variable @ref{racket-indent-curly-as-sequence} is
+not nil.
+@end itemize
-For example:
+Finally and otherwise, a form will be indented as if it were a
+procedure application.
+
+--- --- ---
+
+Note: Racket Mode extends the traditional Emacs lisp indent spec
+to allow a @emph{negative} integer, which means that all distinguished
+forms should align with the first one. This style originated with
+``for/fold'', which has two distinguished forms. Traditionally
+those would indent like this:
@example
-(put 'test-case 'racket-indent-function 1)
+ (for/fold ([x xs])
+ ([y ys]) ; twice body indent
+ body)
@end example
-This will change the indent of @code{test-case} from this:
+However the popularly desired indent is:
@example
-(test-case foo
- blah
- blah)
+ (for/fold ([x xs])
+ ([y ys]) ; same as first distingushed form
+ body)
@end example
-to this:
+This idea extends to optional distinguished forms, such as Typed
+Racket annotation ``prefixes'' in ``for/fold'', ``for/x'', and
+even ``let'' forms:
@example
-(test-case foo
- blah
- blah)
+ (for/fold : Type
+ ([x xs])
+ ([y ys]) ; same as first distingushed form
+ body)
@end example
-If @code{racket-indent-function} has no property for a symbol,
-scheme-indent-function is also considered, although the ``with-''
-indents defined by scheme-mode are ignored. This is only to help
-people who may have extensive scheme-indent-function settings,
-particularly in the form of file or dir local variables.
-Otherwise prefer putting properties on @code{racket-indent-function}.
-
@node racket-smart-open-bracket-mode
@subsection racket-smart-open-bracket-mode
@@ -1058,8 +1272,8 @@ racket-mode and racket-repl-mode buffers, put the following code
in your Emacs init file:
@lisp
-(add-hook 'racket-mode-hook #'racket-unicode-input-method-enable)
-(add-hook 'racket-repl-mode-hook #'racket-unicode-input-method-enable)
+ (add-hook 'racket-mode-hook #'racket-unicode-input-method-enable)
+ (add-hook 'racket-repl-mode-hook #'racket-unicode-input-method-enable)
@end lisp
To temporarily enable this input method for a single buffer you
@@ -1094,15 +1308,15 @@ input method, you may add code like the following example in your
Emacs init file:
@lisp
-;; Either (require 'racket-mode) here, or, if you use
-;; use-package, put the code below in the :config section.
-(with-temp-buffer
- (racket-unicode-input-method-enable)
- (set-input-method "racket-unicode")
- (let ((quail-current-package (assoc "racket-unicode"
- quail-package-alist)))
- (quail-define-rules ((append . t))
- ("^o" ["ᵒ"]))))
+ ;; Either (require 'racket-mode) here, or, if you use
+ ;; use-package, put the code below in the :config section.
+ (with-temp-buffer
+ (racket-unicode-input-method-enable)
+ (set-input-method "racket-unicode")
+ (let ((quail-current-package (assoc "racket-unicode"
+ quail-package-alist)))
+ (quail-define-rules ((append . t))
+ ("^o" ["ᵒ"]))))
@end lisp
If you don’t like the highlighting of partially matching tokens you
@@ -1135,26 +1349,26 @@ Each ``val'' moves to the same column and is
For example with point on the "[" before ``a'':
@example
-Before After
+ Before After
-(let ([a 12] (let ([a 12]
- [bar 23]) [bar 23])
- ....) ....)
+ (let ([a 12] (let ([a 12]
+ [bar 23]) [bar 23])
+ ....) ....)
-'([a . 12] '([a . 12]
- [bar . 23]) [bar . 23])
+ ([a . 12] ([a . 12]
+ [bar . 23]) [bar . 23])
-(cond [a? #t] (cond [a? #t]
- [b? (f x [b? (f x
- y)] y)]
- [else #f]) [else #f])
+ (cond [a? #t] (cond [a? #t]
+ [b? (f x [b? (f x
+ y)] y)]
+ [else #f]) [else #f])
@end example
Or with point on the quote before ``a'':
@example
-(list 'a 12 (list 'a 12
- 'bar 23) 'bar 23)
+ (list a 12 (list a 12
+ bar 23) bar 23)
@end example
If more than one couple is on the same line, none are aligned,
@@ -1163,9 +1377,9 @@ example the following form will not change; @ref{racket-align} will
display an error message:
@example
-(let ([a 0][b 1]
- [c 2]) error; unchanged
- ....)
+ (let ([a 0][b 1]
+ [c 2]) error; unchanged
+ ....)
@end example
When a couple's sexprs start on different lines, that couple is
@@ -1173,11 +1387,11 @@ ignored. Other, single-line couples in the series are aligned as
usual. For example:
@example
-(let ([foo (let ([foo
- 0] 0]
- [bar 1] [bar 1]
- [x 2]) [x 2])
- ....) ....)
+ (let ([foo (let ([foo
+ 0] 0]
+ [bar 1] [bar 1]
+ [x 2]) [x 2])
+ ....) ....)
@end example
See also: @ref{racket-unalign}.
@@ -1219,7 +1433,7 @@ completion candidates, enable the minor mode @ref{racket-xp-mode}.
* racket-xp-tail-next-sibling::
* racket-xp-tail-previous-sibling::
* racket-documentation-search::
-* racket-search-describe::
+* racket-describe-search::
@end menu
@node racket-xp-mode
@@ -1235,8 +1449,8 @@ specific buffer. If you always want to use it, put the following
code in your Emacs init file:
@lisp
-(require 'racket-xp)
-(add-hook 'racket-mode-hook #'racket-xp-mode)
+ (require 'racket-xp)
+ (add-hook 'racket-mode-hook #'racket-xp-mode)
@end lisp
Note: This mode won't do anything unless/until the Racket Mode
@@ -1276,12 +1490,12 @@ Note: If you find these point-motion features too distracting
and/or slow, in your @code{racket-xp-mode-hook} you may disable them:
@lisp
-(require 'racket-xp)
-(add-hook 'racket-xp-mode-hook
- (lambda ()
- (remove-hook 'pre-redisplay-functions
- #'racket-xp-pre-redisplay
- t)))
+ (require 'racket-xp)
+ (add-hook 'racket-xp-mode-hook
+ (lambda ()
+ (remove-hook 'pre-redisplay-functions
+ #'racket-xp-pre-redisplay
+ t)))
@end lisp
The remaining features discussed below will still work.
@@ -1305,14 +1519,14 @@ drracket/check-syntax distinguish the various ``x'' bindings, it
understands the two different imports of ``define'':
@example
-#lang racket/base
-(define x 1)
-x
-(let ([x x])
- (+ x 1))
-(module m typed/racket/base
- (define x 2)
- x)
+ #lang racket/base
+ (define x 1)
+ x
+ (let ([x x])
+ (+ x 1))
+ (module m typed/racket/base
+ (define x 2)
+ x)
@end example
When point is on the opening parenthesis of an expression in tail
@@ -1391,6 +1605,8 @@ commands directly to whatever keys you prefer.
@tab Binding
@item @kbd{M-.}
@tab @code{xref-find-definitions}
+@item @kbd{C-c C-s}
+@tab @ref{racket-describe-search}
@item @kbd{C-c C-d}
@tab @ref{racket-xp-documentation}
@item @kbd{C-c C-.}
@@ -1430,14 +1646,13 @@ commands directly to whatever keys you prefer.
@kbd{C-c C-.}
-Describe something in a @code{*Racket Describe*} buffer.
+Describe the identifier at point.
-The command varies based on how many @kbd{C-u}
-command prefixes you supply.
+The command varies based on how many @kbd{C-u} command prefixes you supply.
-@enumerate
+@itemize
@item
-None.
+@kbd{C-c C-.}
Uses the symbol at point. If no such symbol exists, you are
prompted enter the identifier, but in this case it only
@@ -1458,20 +1673,18 @@ arg-2-name)".
@end itemize
@item
-@kbd{C-u}
+@kbd{C-u} @kbd{C-c C-.}
Always prompts you to enter a symbol, defaulting to the symbol
at point if any.
-Otheriwse behaves like 0.
-
@item
-@kbd{C-u} @kbd{C-u}
+@kbd{C-u} @kbd{C-u} @kbd{C-c C-.}
-This is an alias for @ref{racket-search-describe}, which uses
+This is an alias for @ref{racket-describe-search}, which uses
installed documentation in a @code{racket-describe-mode} buffer
instead of an external web browser.
-@end enumerate
+@end itemize
The intent is to give a quick reminder or introduction to
something, regardless of whether it has installed documentation
@@ -1480,11 +1693,6 @@ something, regardless of whether it has installed documentation
This buffer is also displayed when you use @code{company-mode} and
press F1 or C-h in its pop up completion list.
-You can quit the buffer by pressing q. Also, at the bottom of the
-buffer are Emacs buttons -- which you may navigate among using
-TAB, and activate using RET -- for @code{xref-find-definitions}
-and @ref{racket-xp-documentation}.
-
@node racket-xp-documentation
@subsection racket-xp-documentation
@@ -1495,28 +1703,26 @@ View documentation in an external web browser.
The command varies based on how many @kbd{C-u}
command prefixes you supply.
-@enumerate
+@itemize
@item
-None.
+@kbd{C-c C-d}
Uses the symbol at point. Tries to find documentation for an
identifer defined in the expansion of the current buffer.
If no such identifer exists, opens the Search Manuals page. In
this case, the variable @ref{racket-documentation-search-location}
-determines whether the search is done locally as with `raco
-doc`, or visits a URL.
+determines whether the search is done locally as with @code{raco
+ doc}, or visits a URL.
@item
-@kbd{C-u}
+@kbd{C-u} @kbd{C-c C-d}
Always prompts you to enter a symbol, defaulting to the symbol
at point if any.
-Otherwise behaves like 0.
-
@item
-@kbd{C-u} @kbd{C-u}
+@kbd{C-u} @kbd{C-u} @kbd{C-c C-d}
Always prompts you to enter anything, defaulting to the symbol
at point if any.
@@ -1524,7 +1730,7 @@ at point if any.
Proceeds directly to the Search Manuals page. Use this if you
would like to see documentation for all identifiers named
``define'', for example.
-@end enumerate
+@end itemize
@node racket-xp-next-definition
@subsection racket-xp-next-definition
@@ -1629,10 +1835,10 @@ This command does not try to go directly to the help topic for a
definition provided by any specific module. Instead it goes to
the Racket ``Search Manuals'' page.
-@node racket-search-describe
-@subsection racket-search-describe
+@node racket-describe-search
+@subsection racket-describe-search
-@kbd{M-x} @code{racket-search-describe}
+@kbd{C-c C-.} or @kbd{C-c C-s}
Search installed documentation; view using @code{racket-describe-mode}.
@@ -1702,6 +1908,8 @@ identifier bindings and modules from the REPL's namespace.
@tab @ref{racket-logger}
@item @kbd{C-c C-z}
@tab @code{racket-repl-switch-to-edit}
+@item @kbd{C-c C-s}
+@tab @ref{racket-describe-search}
@item @kbd{C-c C-.}
@tab @ref{racket-repl-describe}
@item @kbd{C-c C-d}
@@ -1752,12 +1960,31 @@ runs the submodules specified by the customization variable
See also @ref{racket-run-module-at-point}, which runs just the
specific module at point.
-With @kbd{C-u} uses errortrace for improved stack traces.
-Otherwise follows the @ref{racket-error-context} setting.
+The command varies based on how many @kbd{C-u}
+prefix arguments you supply.
+
+@itemize
+@item
+@kbd{<f5>}
+
+Follows the @ref{racket-error-context} setting.
+
+@item
+@kbd{C-u} @kbd{<f5>}
-With @kbd{C-u} @kbd{C-u} instruments
-code for step debugging. See @ref{racket-debug-mode} and the variable
-@ref{racket-debuggable-files}.
+Uses errortrace for improved stack traces, as if
+@ref{racket-error-context} were set to ``high''.
+
+This lets you keep @ref{racket-error-context} set to a faster
+value like ``low'' or ``medium'', then conveniently re-run
+when you need a better strack trace.
+
+@item
+@kbd{C-u} @kbd{C-u} @kbd{<f5>}
+
+Instruments code for step debugging. See @ref{racket-debug-mode}
+and the variable @ref{racket-debuggable-files}.
+@end itemize
Each run occurs within a Racket custodian. Any prior run's
custodian is shut down, releasing resources like threads and
@@ -1824,32 +2051,32 @@ Show a Racket REPL buffer in some window.
@strong{IMPORTANT}
The main, intended use of Racket Mode's REPL is that you
-@code{find-file} some specific .rkt file, then @ref{racket-run} it. The
-REPL will then match that file.
+@code{find-file} some specific .rkt file, then run it using
+@ref{racket-run} or @ref{racket-run-module-at-point}. The resulting REPL
+will correspond to those definitions and match your expectations.
-If the REPL isn't running, and you want to start it for no file
-in particular? Then you could use this command. But the resulting
+If you really want to start a REPL for no file in particular,
+then you could use this @ref{racket-repl} command. But the resulting
REPL will have a minimal ``#lang racket/base'' namespace. You
could enter "(require racket)" if you want the equivalent of
``#lang racket''. You could also "(require racket/enter)" if
you want things like ``enter!''. But in some sense you'd be
-``using it wrong''. If you really don't want to use Racket Mode's
-REPL as intended, then you might as well use a plain Emacs shell
-buffer to run command-line Racket.
+``using it wrong''. If you actually don't want to use Racket
+Mode's REPL as intended, then consider using a plain Emacs
+@code{shell} buffer to run command-line Racket.
@node racket-repl-describe
@subsection racket-repl-describe
@kbd{C-c C-.}
-Describe the identifier at point in a @code{*Racket Describe*} buffer.
+Describe the identifier at point.
-The command varies based on how many @kbd{C-u}
-command prefixes you supply.
+The command varies based on how many @kbd{C-u} prefix arguments you supply.
-@enumerate
+@itemize
@item
-None.
+@kbd{C-c C-.}
Uses the symbol at point. If no such symbol exists, you are
prompted enter the identifier, but in this case it only
@@ -1870,30 +2097,23 @@ arg-2-name)".
@end itemize
@item
-@kbd{C-u}
+@kbd{C-u} @kbd{C-c C-.}
Always prompts you to enter a symbol, defaulting to the symbol
at point if any.
-Otheriwse behaves like 0.
-
@item
-@kbd{C-u} @kbd{C-u}
+@kbd{C-u} @kbd{C-u} @kbd{C-c C-.}
-This is an alias for @ref{racket-search-describe}, which uses
+This is an alias for @ref{racket-describe-search}, which uses
installed documentation in a @code{racket-describe-mode} buffer
instead of an external web browser.
-@end enumerate
+@end itemize
The intent is to give a quick reminder or introduction to
something, regardless of whether it has installed documentation
-- and to do so within Emacs, without switching to a web browser.
-You can quit the buffer by pressing q. Also, at the bottom of the
-buffer are Emacs buttons -- which you may navigate among using
-TAB, and activate using RET -- for @code{xref-find-definitions}
-and @ref{racket-repl-documentation}.
-
@node racket-repl-documentation
@subsection racket-repl-documentation
@@ -1903,28 +2123,26 @@ View documentation in an external web browser.
The command varies based on how many @kbd{C-u} command prefixes you supply.
-@enumerate
+@itemize
@item
-None.
+@kbd{C-c C-d}
Uses the symbol at point. Tries to find documentation for an
identifer defined in the current namespace.
If no such identifer exists, opens the Search Manuals page. In
this case, the variable @ref{racket-documentation-search-location}
-determines whether the search is done locally as with `raco
-doc`, or visits a URL.
+determines whether the search is done locally as with @code{raco
+ doc}, or visits a URL.
@item
-@kbd{C-u}
+@kbd{C-u} @kbd{C-c C-d}
Prompts you to enter a symbol, defaulting to the symbol at
point if any.
-Otherwise behaves like 1.
-
@item
-@kbd{C-u} @kbd{C-u}
+@kbd{C-u} @kbd{C-u} @kbd{C-c C-d}
Prompts you to enter anything, defaulting to the symbol at
point if any.
@@ -1932,14 +2150,17 @@ point if any.
Proceeds directly to the Search Manuals page. Use this if you
would like to see documentation for all identifiers named
``define'', for example.
-@end enumerate
+@end itemize
@node racket-racket
@subsection racket-racket
@kbd{<C-M-f5>}
-Do ``racket <file>'' in a shell buffer.
+Use command-line racket to run the file.
+
+Uses a shell or terminal buffer as specified by the configuration
+variable @ref{racket-shell-or-terminal-function}.
@node racket-profile
@subsection racket-profile
@@ -1967,19 +2188,17 @@ delete compiled/*.zo files.
Major mode for results of @ref{racket-profile}.
-@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
@item Key
@tab Binding
-@item @kbd{,}
-@tab @code{racket-profile-sort}
+@item @kbd{RET}
+@tab @code{racket-profile-visit}
+@item @kbd{.}
+@tab @code{racket-profile-visit}
@item @kbd{f}
@tab @code{racket-profile-show-non-project}
@item @kbd{z}
@tab @code{racket-profile-show-zero}
-@item @kbd{p}
-@tab @code{racket-profile-prev}
-@item @kbd{n}
-@tab @code{racket-profile-next}
@item @kbd{g}
@tab @code{racket-profile-refresh}
@item @kbd{q}
@@ -1989,7 +2208,7 @@ Major mode for results of @ref{racket-profile}.
-In addition to any hooks its parent mode @code{special-mode} might have run,
+In addition to any hooks its parent mode @code{tabulated-list-mode} might have run,
this mode runs the hook @code{racket-profile-mode-hook}, as the final step
during initialization.
@@ -2007,7 +2226,6 @@ Create the @ref{racket-logger-mode} buffer.
Major mode for Racket logger output.
-
The customization variable @ref{racket-logger-config} determines the
levels for topics. During a session you may change topic levels
using @code{racket-logger-topic-level}.
@@ -2054,17 +2272,14 @@ How to debug:
@enumerate
@item
-``Instrument'' code for step debugging. You can instrument
-entire files, and also individual functions.
-
-a. Entire Files
+``Instrument'' code for step debugging.
Use two @kbd{C-u} command prefixes for either
@ref{racket-run} or @ref{racket-run-module-at-point}.
-The file will be instrumented for step debugging before it
-is run. Also instrumented are files determined by the
-variable @ref{racket-debuggable-files}.
+The file will be instrumented for step debugging before it is
+run. Any imported files are also instrumented if they are in
+the variable @ref{racket-debuggable-files}.
The run will break at the first breakable position.
@@ -2073,38 +2288,6 @@ REPL prompt, the code remains instrumented. You may enter
expressions that evaluate instrumented code and it will
break so you can step debug again.
-b. Function Definitions
-
-Move point inside a function definition form and use
-@kbd{C-u} @kbd{C-M-x} to
-``instrument'' the function for step debugging. Then in the
-REPL, enter an expression that causes the instrumented
-function to be run, directly or indirectly.
-
-You can instrument any number of functions.
-
-You can even instrument while stopped at a break. For
-example, to instrument a function you are about to call, so
-you can ``step into'' it:
-
-@itemize
-@item
-@kbd{M-x} @code{racket-xp-visit-definition} to visit the definition.
-@item
-@kbd{C-u} @kbd{C-M-x} to instrument the definition.
-@item
-@kbd{M-x} @code{racket-unvisit} to return.
-@item
-Continue stepping.
-@end itemize
-Limitation: Instrumenting a function required from another
-module won't redefine that function. Instead, it attempts
-to define an instrumented function of the same name, in the
-module the REPL is inside. The define will fail if it needs
-definitions visible only in that other module. In that case
-you'll probably need to use entire-file instrumentation as
-described above.
-
@item
When a break occurs, the @ref{racket-repl-mode} prompt changes. In
this debug REPL, local variables are available for you to use
@@ -2117,17 +2300,25 @@ position, local variable values, and result values -- and
provides shortcut keys:
@end enumerate
-@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
+@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa} {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
@item Key
@tab Binding
@item @kbd{?}
@tab @code{racket-debug-help}
@item @kbd{h}
@tab @code{racket-debug-run-to-here}
+@item @kbd{!}
+@tab @ref{racket-debug-toggle-breakpoint}
+@item @kbd{P}
+@tab @code{racket-debug-prev-breakpoint}
+@item @kbd{N}
+@tab @code{racket-debug-next-breakpoint}
@item @kbd{p}
@tab @code{racket-debug-prev-breakable}
@item @kbd{n}
@tab @code{racket-debug-next-breakable}
+@item @kbd{g}
+@tab @code{racket-debug-go}
@item @kbd{c}
@tab @code{racket-debug-continue}
@item @kbd{u}
@@ -2177,17 +2368,20 @@ Run the ``test'' submodule.
Put your tests in a ``test'' submodule. For example:
@example
-(module+ test
- (require rackunit)
- (check-true #t))
+ (module+ test
+ (require rackunit)
+ (check-true #t))
@end example
Any rackunit test failure messages show the location. You may use
@code{next-error} to jump to the location of each failing test.
-With @kbd{C-u} also runs the tests with coverage
-instrumentation and highlights uncovered code using
-@code{font-lock-warning-face}.
+With @kbd{C-u} uses errortrace for improved stack traces.
+Otherwise follows the @ref{racket-error-context} setting.
+
+With @kbd{C-u} @kbd{C-u} also runs the
+tests with coverage instrumentation and highlights uncovered code
+using @code{font-lock-warning-face}.
See also:
@itemize
@@ -2202,7 +2396,10 @@ See also:
@kbd{M-x} @code{racket-raco-test}
-Do ``raco test -x <file>'' in a shell buffer to run the ``test'' submodule.
+Use command-line raco test to run the ``test'' submodule.
+
+Uses a shell or terminal buffer as specified by the configuration
+variable @ref{racket-shell-or-terminal-function}.
@node Eval
@section Eval
@@ -2232,17 +2429,22 @@ Send the current definition to the Racket REPL.
@kbd{C-x C-e}
-Send the previous sexp to the Racket REPL.
+Send the expression before point to the Racket REPL.
+
+The expression may be either an at-expression or an s-expression.
-When the previous sexp is a sexp comment the sexp itself is sent,
+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
+from the zero or more values to which it evaluates.
+
@node Collections
@section Collections
@menu
* racket-open-require-path::
-* racket-find-collection::
@end menu
@node racket-open-require-path
@@ -2269,34 +2471,6 @@ RET on a file exits doing @code{find-file}.
C-g aborts.
@end itemize
-@node racket-find-collection
-@subsection racket-find-collection
-
-@kbd{M-x} @code{racket-find-collection}
-
-Given a collection name, try to find its directory and files.
-
-Takes a collection name from point.
-
-With @kbd{C-u} prompts you.
-
-If only one directory is found, @code{ido-find-file-in-dir} lets you
-pick a file there.
-
-If more than one directory is found, @code{ido-completing-read} lets
-you pick one, then @code{ido-find-file-in-dir} lets you pick a file
-there.
-
-Note: This requires the @code{raco-find-collection} package to be
-installed. To install it, in @code{shell} enter:
-
-raco pkg install raco-find-collection
-
-Tip: This works best with @code{ido-enable-flex-matching} set to t.
-Also handy is the @code{flx-ido} package from MELPA.
-
-See also: @ref{racket-open-require-path}.
-
@node Macro expand
@section Macro expand
@@ -2315,7 +2489,6 @@ See also: @ref{racket-open-require-path}.
Major mode for Racket stepper output.
-
Used by the commands @ref{racket-expand-file},
@ref{racket-expand-definition}, @ref{racket-expand-region}, and
@ref{racket-expand-last-sexp}.
@@ -2395,20 +2568,73 @@ Uses Racket's @code{expand-once} in the namespace from the most recent
@section Other
@menu
+* racket-debug-toggle-breakpoint::
* racket-mode-start-faster::
* racket-mode-start-slower::
@end menu
-@node racket-mode-start-faster
-@subsection racket-mode-start-faster
+@node racket-debug-toggle-breakpoint
+@subsection racket-debug-toggle-breakpoint
-@kbd{M-x} @code{racket-mode-start-faster}
+@kbd{M-x} @code{racket-debug-toggle-breakpoint}
-Compile Racket Mode's .rkt files for faster startup.
+Add or remove a breakpoint.
-Racket Mode is implemented as an Emacs Lisp ``front end'' that
-talks to a Racket process ``back end''. Because Racket Mode is
-delivered as an Emacs package instead of a Racket package,
+Each breakpoint has a condition and a list of actions.
+
+The condition is a Racket expression that is evaluated in a
+context where local variables exist. Examples:
+
+@itemize
+@item
+``#t'' means break always.
+
+@item
+If the code around the breakpoint is something like
+"(for ([n 100]) _)", then a condition like
+"(zero? (modulo n 10))" is every 10 times through the
+loop.
+@end itemize
+
+Actions is a list of symbols; you may specify one or more. The
+action symbols are:
+
+@itemize
+@item
+``break'' causes a break, enabling @ref{racket-debug-mode}.
+
+@item
+``log'' and ``print'' display information about local
+variables to the logger or REPL output, respectively.
+Although @ref{racket-debug-mode} already shows these values ``in
+situ'' when you reach a break, this may be useful if you want
+a history. Specifying ``log'' or ``print'', but not
+``break'', is equivalent to what many debuggers call a
+watchpoint instead of a breakpoint: Output some information
+and automatically resume.
+@end itemize
+
+Note: Although @ref{racket-debug-mode} provides a convenient
+keybinding, you may invoke this command anytime using M-x.
+
+Note: If you're warned that point isn't known to be a breakable
+position, that might be because it truly isn't, or, just because
+you are not in @ref{racket-debug-mode} and the breakable positions
+aren't yet known. Worst case, if you set a breakpoint someplace
+that is not breakable, it is ignored. With a few exceptions --
+such as close paren positions that are tail calls -- most open
+parens and close parens are breakble positions.
+
+@node racket-mode-start-faster
+@subsection racket-mode-start-faster
+
+@kbd{M-x} @code{racket-mode-start-faster}
+
+Compile Racket Mode's .rkt files for faster startup.
+
+Racket Mode is implemented as an Emacs Lisp ``front end'' that
+talks to a Racket process ``back end''. Because Racket Mode is
+delivered as an Emacs package instead of a Racket package,
installing it does not do the @code{raco setup} that is normally done
for Racket packages.
@@ -2444,146 +2670,6 @@ To revert to compiling on startup, use
Delete the ``compiled'' directories made by @ref{racket-mode-start-faster}.
-@node Showing information
-@section Showing information
-
-@menu
-* racket-show-pseudo-tooltip::
-* racket-show-echo-area::
-* racket-show-header-line::
-* racket-show-pos-tip::
-@end menu
-
-@node racket-show-pseudo-tooltip
-@subsection racket-show-pseudo-tooltip
-
-Show using an overlay that resembles a tooltip.
-
-This is nicer than @ref{racket-show-pos-tip} because it:
-
-@itemize
-@item
-Doesn't flicker while navigating.
-@item
-Doesn't disappear after a timeout.
-@item
-Performs well when @code{x-gtk-use-system-tooltips} is nil.
-@end itemize
-
-On the other hand, this does not look as nice when displaying
-text that spans multiple lines. In that case, we simply
-left-justify everything and do not draw any border.
-
-@node racket-show-echo-area
-@subsection racket-show-echo-area
-
-Show things in the echo area.
-
-A value for the variable @ref{racket-show-functions}.
-
-@node racket-show-header-line
-@subsection racket-show-header-line
-
-Show things using a buffer header line.
-
-A value for the variable @ref{racket-show-functions}.
-
-When there is nothing to show, keep a blank header-line. That
-way, the buffer below doesn't ``jump up and down'' by a line as
-messages appear and disappear. Only when V is nil do we remove
-the header line.
-
-@node racket-show-pos-tip
-@subsection racket-show-pos-tip
-
-Show things using @code{pos-tip-show} if available.
-
-A value for the variable @ref{racket-show-functions}.
-
-@node Associating edit buffers with REPL buffers
-@section Associating edit buffers with REPL buffers
-
-@menu
-* racket-repl-buffer-name-shared::
-* racket-repl-buffer-name-unique::
-* racket-repl-buffer-name-project::
-* racket-project-root::
-@end menu
-
-@node racket-repl-buffer-name-shared
-@subsection racket-repl-buffer-name-shared
-
-@kbd{M-x} @code{racket-repl-buffer-name-shared}
-
-All @ref{racket-mode} edit buffers share one @ref{racket-repl-mode} buffer.
-
-A value for the variable @ref{racket-repl-buffer-name-function}.
-
-@node racket-repl-buffer-name-unique
-@subsection racket-repl-buffer-name-unique
-
-@kbd{M-x} @code{racket-repl-buffer-name-unique}
-
-Each @ref{racket-mode} edit buffer gets its own @ref{racket-repl-mode} buffer.
-
-A value for the variable @ref{racket-repl-buffer-name-function}.
-
-@node racket-repl-buffer-name-project
-@subsection racket-repl-buffer-name-project
-
-@kbd{M-x} @code{racket-repl-buffer-name-project}
-
-All @ref{racket-mode} buffers in a project share a @ref{racket-repl-mode} buffer.
-
-A value for the variable @ref{racket-repl-buffer-name-function}.
-
-The ``project'' is determined by @ref{racket-project-root}.
-
-@node racket-project-root
-@subsection racket-project-root
-
-Given an absolute pathname for FILE, return its project root directory.
-
-The ``project'' is determined by trying, in order:
-
-@itemize
-@item
-@code{projectile-project-root}
-@item
-@code{vc-root-dir}
-@item
-@code{project-current}
-@item
-@code{file-name-directory}
-@end itemize
-
-@node Browsing file URLs with anchors
-@section Browsing file URLs with anchors
-
-@menu
-* racket-browse-url-using-temporary-file::
-@end menu
-
-@node racket-browse-url-using-temporary-file
-@subsection racket-browse-url-using-temporary-file
-
-Browse a URL via a temporary HTML file using a meta redirect.
-
-A suitable value for the variable @ref{racket-browse-url-function}.
-
-Racket documentation URLs depend on anchors -- the portion of the
-URL after the # character -- to jump to a location within a page.
-Unfortunately on some operating systems and/or versions of Emacs,
-the default handling for browsing file URLs ignores anchors. This
-function attempts to avoid the problem by using a temporary HTML
-file with a meta redirect as a ``trampoline''.
-
-Although the intent is to provide a default that ``just works'',
-you do not need to use this. You can customize the variable
-@ref{racket-browse-url-function} instead to be @code{browse-url}, or
-@code{browse-url-browser-function} in case have have customized that,
-or indeed whatever you want.
-
@node Variables
@chapter Variables
@@ -2592,7 +2678,8 @@ or indeed whatever you want.
* REPL variables::
* Other variables::
* Experimental debugger variables::
-* Showing information: Showing informationx.
+* Showing information::
+* Running racket and raco commands in a shell or terminal::
@end menu
@node General variables
@@ -2604,8 +2691,6 @@ or indeed whatever you want.
* racket-memory-limit::
* racket-error-context::
* racket-user-command-line-arguments::
-* racket-path-from-emacs-to-racket-function::
-* racket-path-from-racket-to-emacs-function::
* racket-browse-url-function::
* racket-xp-after-change-refresh-delay::
* racket-xp-highlight-unused-regexp::
@@ -2615,7 +2700,11 @@ or indeed whatever you want.
@node racket-program
@subsection racket-program
-Pathname of the racket executable.
+Pathname of the Racket executable.
+
+Note that a back end configuration can override this with a
+non-nil @code{racket-program} property list value. See
+@ref{racket-add-back-end}.
@node racket-command-timeout
@subsection racket-command-timeout
@@ -2682,50 +2771,25 @@ This is an Emacs buffer-local variable --- convenient to set as a
file local variable. For example at the end of your .rkt file:
@lisp
-;; Local Variables:
-;; racket-user-command-line-arguments: ("-f" "bar")
-;; End:
+ ;; Local Variables:
+ ;; racket-user-command-line-arguments: ("-f" "bar")
+ ;; End:
@end lisp
Set this way, the value must be an @strong{unquoted} list of strings.
For example:
@lisp
-("-f" "bar")
+ ("-f" "bar")
@end lisp
The following values will @emph{not} work:
@lisp
-'("-f" "bar")
-(list "-f" "bar")
+ '("-f" "bar")
+ (list "-f" "bar")
@end lisp
-@node racket-path-from-emacs-to-racket-function
-@subsection racket-path-from-emacs-to-racket-function
-
-A function to transform Emacs Lisp pathnames given to the Racket back end.
-
-If you run Emacs on Windows Subsystem for Linux, and want to run
-Racket programs using Windows Racket.exe rather than Linux
-racket, you can set this to @code{racket-wsl-to-windows}. In that case
-you probably also want to customize the ``reverse'':
-@ref{racket-path-from-racket-to-emacs-function}.
-
-@node racket-path-from-racket-to-emacs-function
-@subsection racket-path-from-racket-to-emacs-function
-
-A function to transform Racket back end pathnames given to Emacs Lisp.
-
-The default on Windows replaces back with forward slashes. The
-default elsewhere is @code{identity}.
-
-If you run Emacs on Windows Subsystem for Linux, and want to run
-Racket programs using Windows Racket.exe rather than Linux
-racket, you can set this to @code{racket-windows-to-wsl}. In that case
-you probably also want to customize the ``reverse'':
-@ref{racket-path-from-emacs-to-racket-function}.
-
@node racket-browse-url-function
@subsection racket-browse-url-function
@@ -2755,14 +2819,14 @@ and @ref{racket-repl-documentation} should look for the search page.
@itemize
@item
-If the value of this variable is `local, open the search page
-from the local documentation, as with ``raco doc''.
+If the value of this variable is the symbol ``local'', open the
+search page from the local documentation, as with ``raco doc''.
@item
Otherwise, the value is a string recognizable by @code{format}, with
-``%s'' at the point at which to insert the user's search text.
-the help desk. Apart from ``%s'', the string should be a
-properly encoded URL.
+``%s'' at the point at which to insert the user's search text
+after applying @code{url-hexify-string}. Apart from ``%s'', the
+string should be a properly encoded URL.
@end itemize
@node REPL variables
@@ -2795,7 +2859,7 @@ This is used when a @ref{racket-mode} buffer is created. Changing
this to a new value only affects @ref{racket-mode} buffers created
later.
-Any such function takes no arguments, should look at
+Any such function takes no arguments, should look at the variable
@code{buffer-file-name} if necessary, and either @code{setq-default} or
@code{setq-local} the variable @code{racket-repl-buffer-name} to a desired
@ref{racket-repl-mode} buffer name. As a result, @ref{racket-run}
@@ -2813,7 +2877,6 @@ list, to support submodules nested to any depth.
This is used by commands that emulate the DrRacket Run command:
-
@itemize
@item
@ref{racket-run}
@@ -2887,6 +2950,7 @@ Use pretty-print instead of print in REPL?
* racket-logger-config::
* racket-before-run-hook::
* racket-after-run-hook::
+* racket-sexp-comment-fade::
@end menu
@node racket-indent-curly-as-sequence
@@ -2904,9 +2968,9 @@ To what depth should @ref{racket-indent-line} search.
This affects the indentation of forms like '() `() #() --
and @{@} if @ref{racket-indent-curly-as-sequence} is t --- but not
-#'() #`() ,() ,@@(). A zero value disables, giving the normal
-indent behavior of DrRacket or Emacs @code{lisp-mode} derived modes
-like @code{scheme-mode}. Setting this to a high value can make
+#'() #`() ,() ,@@(). A zero value disables, giving the
+normal indent behavior of DrRacket or Emacs @code{lisp-mode} derived
+modes like @code{scheme-mode}. Setting this to a high value can make
indentation noticeably slower. This is safe to set as a
file-local variable.
@@ -2932,19 +2996,19 @@ and/or @code{racket-repl-mode-map} keymaps.
Configuration of @ref{racket-logger-mode} topics and levels.
-The topic `* respresents the default level used for topics not
+The topic ``*'' respresents the default level used for topics not
assigned a level. Otherwise, the topic symbols are the same as
used by Racket's @code{define-logger}.
-The levels are those used by Racket's logging system: `debug,
-`info, `warning, `error, `fatal.
+The levels are those used by Racket's logging system: ``debug'',
+``info'', ``warning'', ``error'', ``fatal''.
For more information see:
@uref{https://docs.racket-lang.org/reference/logging.html}
The default value sets some known ``noisy'' topics to be one
-level quieter. That way you can set the `* topic to a level like
-`debug and not get overhwelmed by these noisy topics.
+level quieter. That way you can set the ``*'' topic to a level
+like ``debug'' and not get overhwelmed by these noisy topics.
@node racket-before-run-hook
@subsection racket-before-run-hook
@@ -2969,6 +3033,21 @@ When hook functions are called, @code{current-buffer} is that of the
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
+
+How much to fade faces used in s-expression comment bodies.
+
+A number from 0.0 to 1.0, where 0.0 is 0% fade and 1.0 is 100%
+fade (invisible).
+
+This feature works by creating faces that are alternatives for
+faces used in s-expression comments. The alernative faces use a
+faded foreground color. The colors are recalculated automatically
+after you change the value of this customization variable and
+after any @code{load-theme}. However in other circumstances you might
+need to use @code{racket-refresh-sexp-comment-faces}.
+
@node Experimental debugger variables
@section Experimental debugger variables
@@ -2980,16 +3059,19 @@ get that from the variable @code{racket-repl-buffer-name}.
@subsection racket-debuggable-files
Used to tell @ref{racket-run} what files may be instrumented for debugging.
-Must be a list of strings that are pathnames, such as from
-@code{racket--buffer-file-name}, -or-, a function that returns such a
-list given the pathname of the file being run. If any path
-strings are relative, they are made absolute using
-@code{expand-file-name} with the directory of the file being run. The
-symbol `run-file may be supplied in the list; it will be replaced
-with the pathname of the file being run. Safe to set as a
-file-local variable.
-@node Showing informationx
+This isn't yet a defcustom becuase the debugger status is still
+``experimental''.
+
+Must be either a list of file name strings, or, a function that
+takes the name of the file being run and returns a list of file
+names.
+
+Each file name in the list is made absolute using
+@code{expand-file-name} with respect to the file being run and given
+to @code{racket-file-name-front-to-back}.
+
+@node Showing information
@section Showing information
@menu
@@ -2999,42 +3081,473 @@ file-local variable.
@node racket-show-functions
@subsection racket-show-functions
-A special hook variable to customize @code{racket-show}.
+An ``abnormal hook'' variable to customize @code{racket-show}.
-Example functions include:
+This is a list of one or more functions.
+
+Each such function must accept two arguments: STR and POS.
+
+STR is one of:
@itemize
@item
-@ref{racket-show-pseudo-tooltip}
-@item
-@ref{racket-show-echo-area}
+Non-blank string: Display the string somehow.
+
@item
-@ref{racket-show-pos-tip}
+Blank string: Hide any previously displayed string.
+
@item
+nil: Hide any persistent UI that might have been created. For
+instance @ref{racket-show-header-line} hides the header line.
+@end itemize
+
+POS may be nil when STR is nil or a blank string.
+
+Otherwise POS is the buffer position -- typically the end of a
+span -- that the non-blank STR describes.
+
+A function that shows STR near POS should position it not to hide
+the span, i.e. below and/or right of POS. Examples:
+@ref{racket-show-pseudo-tooltip} and @ref{racket-show-pos-tip}.
+
+A function that shows STR in a fixed location may of course
+ignore POS. Examples: @ref{racket-show-echo-area} and
@ref{racket-show-header-line}
+
+@node Running racket and raco commands in a shell or terminal
+@section Running racket and raco commands in a shell or terminal
+
+@menu
+* racket-shell-or-terminal-function::
+@end menu
+
+@node racket-shell-or-terminal-function
+@subsection racket-shell-or-terminal-function
+
+How @ref{racket-racket} and @ref{racket-raco-test} run commands.
+
+The function should accept a command string, not including a
+newline, get or create a suitable buffer, send the command, and
+send a newline or enter.
+
+Predefined choices include @ref{racket-shell}, @ref{racket-term},
+@ref{racket-ansi-term}, and @ref{racket-vterm}.
+
+@node Configuration functions
+@chapter Configuration functions
+
+@menu
+* Showing information: Showing informationx.
+* Associating edit buffers with REPL buffers::
+* Browsing file URLs with anchors::
+* Configuring back ends::
+* Running racket and raco commands in a shell or terminal: Running racket and raco commands in a shell or terminalx.
+@end menu
+
+@node Showing informationx
+@section Showing information
+
+@menu
+* racket-show-pseudo-tooltip::
+* racket-show-echo-area::
+* racket-show-header-line::
+* racket-show-pos-tip::
+@end menu
+
+@node racket-show-pseudo-tooltip
+@subsection racket-show-pseudo-tooltip
+
+@code{(racket-show-pseudo-tooltip str &optional pos)}
+
+
+Show using an overlay that resembles a tooltip.
+
+This is nicer than @ref{racket-show-pos-tip} because it:
+
+@itemize
+@item
+Doesn't flicker while navigating.
+@item
+Doesn't disappear after a timeout.
+@item
+Performs well when @code{x-gtk-use-system-tooltips} is nil.
@end itemize
-Each function should accept two arguments: VAL and POS.
+On the other hand, this does not look as nice when displaying
+text that spans multiple lines or is too wide to fit the window.
+In that case, we simply left-justify everything and do not draw
+any border.
+
+@node racket-show-echo-area
+@subsection racket-show-echo-area
+
+@code{(racket-show-echo-area str &optional _pos)}
+
+
+Show things in the echo area.
+
+A value for the variable @ref{racket-show-functions}.
+
+This does @emph{not} add STR to the ``@strong{Messages}'' log buffer.
+
+@node racket-show-header-line
+@subsection racket-show-header-line
+
+@code{(racket-show-header-line str &optional _pos)}
+
+
+Show things using a buffer header line.
+
+A value for the variable @ref{racket-show-functions}.
+
+When there is nothing to show, keep a blank header-line. That
+way, the buffer below doesn't ``jump up and down'' by a line as
+messages appear and disappear. Only when V is nil do we remove
+the header line.
+
+@node racket-show-pos-tip
+@subsection racket-show-pos-tip
+
+@code{(racket-show-pos-tip str &optional pos)}
+
+
+Show things using @code{pos-tip-show} if available.
+
+A value for the variable @ref{racket-show-functions}.
+
+@node Associating edit buffers with REPL buffers
+@section Associating edit buffers with REPL buffers
+
+@menu
+* racket-repl-buffer-name-shared::
+* racket-repl-buffer-name-unique::
+* racket-repl-buffer-name-project::
+* racket-project-root::
+@end menu
+
+@node racket-repl-buffer-name-shared
+@subsection racket-repl-buffer-name-shared
+
+@code{(racket-repl-buffer-name-shared)}
+
+
+All @ref{racket-mode} edit buffers share one @ref{racket-repl-mode} buffer per back end.
+
+A value for the variable @ref{racket-repl-buffer-name-function}.
+
+@node racket-repl-buffer-name-unique
+@subsection racket-repl-buffer-name-unique
+
+@code{(racket-repl-buffer-name-unique)}
+
+
+Each @ref{racket-mode} edit buffer gets its own @ref{racket-repl-mode} buffer.
+
+A value for the variable @ref{racket-repl-buffer-name-function}.
+
+@node racket-repl-buffer-name-project
+@subsection racket-repl-buffer-name-project
+
+@code{(racket-repl-buffer-name-project)}
+
+
+All @ref{racket-mode} buffers in a project share a @ref{racket-repl-mode} buffer.
+
+A value for the variable @ref{racket-repl-buffer-name-function}.
+
+The ``project'' is determined by @ref{racket-project-root}.
+
+@node racket-project-root
+@subsection racket-project-root
+
+@code{(racket-project-root file)}
+
+
+Given an absolute pathname for FILE, return its project root directory.
-VAL is:
+The ``project'' is determined by trying, in order:
@itemize
@item
-Non-blank string: Display the string somehow.
+@code{projectile-project-root}
+@item
+@code{vc-root-dir}
+@item
+@code{project-current}
+@item
+@code{file-name-directory}
+@end itemize
+
+@node Browsing file URLs with anchors
+@section Browsing file URLs with anchors
+
+@menu
+* racket-browse-url-using-temporary-file::
+@end menu
+
+@node racket-browse-url-using-temporary-file
+@subsection racket-browse-url-using-temporary-file
+
+@code{(racket-browse-url-using-temporary-file url &rest _args)}
+
+Browse a URL via a temporary HTML file using a meta redirect.
+
+A suitable value for the variable @ref{racket-browse-url-function}.
+
+Racket documentation URLs depend on anchors -- the portion of the
+URL after the # character -- to jump to a location within a page.
+Unfortunately on some operating systems and/or versions of Emacs,
+the default handling for browsing file URLs ignores anchors. This
+function attempts to avoid the problem by using a temporary HTML
+file with a meta redirect as a ``trampoline''.
+
+Although the intent is to provide a default that ``just works'',
+you do not need to use this. You can customize the variable
+@ref{racket-browse-url-function} instead to be @code{browse-url}, or
+@code{browse-url-browser-function} in case have have customized that,
+or indeed whatever you want.
+
+@node Configuring back ends
+@section Configuring back ends
+
+@menu
+* racket-add-back-end::
+@end menu
+
+@node racket-add-back-end
+@subsection racket-add-back-end
+
+@code{(racket-add-back-end directory &rest plist)}
+
+
+Add a description of a Racket Mode back end.
+
+Racket Mode supports one or more back ends, which are Racket
+processes supporting REPLs as well as various other Racket Mode
+features.
+
+DIRECTORY is a string describing a @code{file-name-absolute-p}
+directory on some local or remote server.
+
+When a back end's DIRECTORY is the longest matching prefix of a
+buffer's @code{default-directory}, that back end is used for the
+buffer.
+
+DIRECTORY can be a local directory like ``/'' or
+``/path/to/project'', or a @code{file-remote-p} directory like
+``/user@@host:'' or ``/user@@host:/path/to/project''.
+
+Note that you need not include a method -- such as the ``ssh'' in
+``/ssh:user@@host:'' -- and if you do it is stripped: A back end
+process is always started using SSH. Even if multiple buffers for
+the same user+host+port use different methods, they will share
+the same back end.
+
+Practically speaking, DIRECTORY is a path you could give to
+@code{find-file} to successfully find some local or remote file, but
+omitting any method. (Some remote file shorthand forms get
+expanded to at least ``/method:host:''. When in doubt check
+@code{buffer-file-name} and follow its example.)
+
+In addition to being used as a pattern to pick a back end for a
+buffer, DIRECTORY determines:
+
+@itemize
@item
-Blank string: Hide any previously displayed string.
+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
+~/.ssh/config).
+
+@item
+Other properties get reasonable defaults based on whether the
+back end is local or remote, as described below.
+@end itemize
+
+After DIRECTORY, the remainining arguments are optional; they are
+alternating :keywords and values describing some other properties
+of a back end:
+
+@itemize
+@item
+:racket-program
+
+When not nil this is used instead of the value of the
+customization variable @ref{racket-program}.
+
+@item
+:remote-source-dir
+
+Where on a remote host to copy the back end's *.rkt files when
+they do not exist or do not match the digest of the local
+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
+front end (which uses slashes even on Windows) and the Racket
+back end (which expects native backslashes on Windows).
+
+@item
+:restart-watch-directories
+
+A list of @code{directory-name-p} strings. Each directory, and
+recursively its subdirectories, will be watched for file system
+changes. After any changes are detected, the next
+@ref{racket-run} (or @ref{racket-run-module-at-point} etc.) command
+will ask you if it should restart the back end for you. This
+may be helpful when you are changing source files used by the
+back end.
+@end itemize
+
+The default property values are appropriate for whether
+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''.
@item
-nil: Hide any persistent UI that might have been created to
-show strings, such as by @ref{racket-show-header-line}.
+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}.
@end itemize
-POS is the buffer position for which to show the message. It may
-be nil only when VAL is nil or a blank string. When the buffer
-content is a span, POS should be the end of the span. That way,
-for example, a function that shows a tooltip can position it not
-to hide the interesting span in the buffer.
+Although the default values usually ``just work'' for local and
+remote back ends, you might want a special configuration. Here
+are a few examples.
+
+@lisp
+ ;; 1. A back end configuration for "/" is
+ ;; created automatically and works fine as a default
+ ;; for buffers visiting local files, so we don't need
+ ;; to add one here.
+
+ ;; 2. However assume we want buffers under /var/tmp/8.0
+ ;; instead to use Racket 8.0.
+ (racket-add-back-end "/var/tmp/8.0"
+ :racket-program "~/racket/8.0/bin/racket")
+
+ ;; 3. A back end configuration will be created
+ ;; automatically for buffers visiting file names like
+ ;; "/ssh:user@@linode", so we don't need to add one here.
+ ;;
+ ;; If ~/.ssh/config defines a Host alias named "linode",
+ ;; with HostName and User settings, a file name as simple as
+ ;; "/linode:" would work fine with tramp -- and the
+ ;; automatically created back end configuration would work
+ ;; fine, too.
+
+ ;; 4. For example's sake, assume for buffers visiting
+ ;; /ssh:headless:~/gui-project/ we want :racket-program instead
+ ;; to be "xvfb-run racket".
+ (racket-add-back-end "/ssh:headless:~/gui-project/"
+ :racket-program "xvfb-run racket")
+@end lisp
+
+@node Running racket and raco commands in a shell or terminalx
+@section Running racket and raco commands in a shell or terminal
+
+@menu
+* racket-shell::
+* racket-term::
+* racket-ansi-term::
+* racket-vterm::
+@end menu
+
+@node racket-shell
+@subsection racket-shell
+
+@code{(racket-shell cmd)}
+
+
+Run CMD using @code{shell}.
+
+A value for the variable @ref{racket-shell-or-terminal-function}.
+
+@node racket-term
+@subsection racket-term
+
+@code{(racket-term cmd)}
+
+
+Run CMD using @code{term}.
+
+A value for the variable @ref{racket-shell-or-terminal-function}.
+
+@node racket-ansi-term
+@subsection racket-ansi-term
+
+@code{(racket-ansi-term cmd)}
+
+
+Run CMD using @code{ansi-term}.
+
+A value for the variable @ref{racket-shell-or-terminal-function}.
+
+@node racket-vterm
+@subsection racket-vterm
+
+@code{(racket-vterm cmd)}
+
+
+Run CMD using @code{vterm}, if that package is installed.
+
+A value for the variable @ref{racket-shell-or-terminal-function}.
@node Faces
@chapter Faces
@@ -3048,7 +3561,8 @@ to hide the interesting span in the buffer.
@menu
* racket-keyword-argument-face::
-* racket-selfeval-face::
+* racket-reader-quoted-symbol-face::
+* racket-reader-syntax-quoted-symbol-face::
* racket-here-string-face::
* racket-xp-def-face::
* racket-xp-use-face::
@@ -3062,6 +3576,10 @@ to hide the interesting span in the buffer.
* racket-logger-warning-face::
* racket-logger-info-face::
* racket-logger-debug-face::
+* racket-doc-link-face::
+* racket-ext-link-face::
+* racket-doc-output-face::
+* racket-doc-litchar-face::
@end menu
@node racket-keyword-argument-face
@@ -3069,10 +3587,25 @@ to hide the interesting span in the buffer.
Face for @code{#:keyword} arguments.
-@node racket-selfeval-face
-@subsection racket-selfeval-face
+@node racket-reader-quoted-symbol-face
+@subsection racket-reader-quoted-symbol-face
+
+Face for symbols quoted using ' or `.
+
+This face is given only to symbols directly quoted using the
+reader shorthands ' or `. All other directly quoted values,
+including symbols quoted using ``quote'' or ``quasiquote'', get
+the face @code{font-lock-constant-face}.
-Face for self-evaluating expressions like numbers, symbols, strings.
+@node racket-reader-syntax-quoted-symbol-face
+@subsection racket-reader-syntax-quoted-symbol-face
+
+Face for symbols quoted using #' or #`.
+
+This face is given only to symbols directly quoted using the
+reader shorthands #' or #`. All other directly quoted
+values, including symbols quoted using ``syntax'' or
+``quasisyntax'', get the face @code{font-lock-constant-face}.
@node racket-here-string-face
@subsection racket-here-string-face
@@ -3139,5 +3672,29 @@ Face for @ref{racket-logger-mode} info level.
Face for @ref{racket-logger-mode} debug level.
+@node racket-doc-link-face
+@subsection racket-doc-link-face
+
+Face @code{racket-describe-mode} uses for links within documentation.
+Note: When some special face is already specified by the
+documentation, then to avoid visual clutter this face is NOT also
+added.
+
+@node racket-ext-link-face
+@subsection racket-ext-link-face
+
+Face @code{racket-describe-mode} uses for external links.
+See the variable @ref{racket-browse-url-function}.
+
+@node racket-doc-output-face
+@subsection racket-doc-output-face
+
+Face @code{racket-describe-mode} uses for Scribble @@example or @@interactions output.
+
+@node racket-doc-litchar-face
+@subsection racket-doc-litchar-face
+
+Face @code{racket-describe-mode} uses for Scribble @@litchar.
+
@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
new file mode 100644
index 0000000..c48838d
--- /dev/null
+++ b/racket-back-end.el
@@ -0,0 +1,602 @@
+;;; racket-back-end.el -*- lexical-binding: t; -*-
+
+;; Copyright (c) 2021-2022 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
+
+;;; Back end: configuration
+
+(require 'cl-macs)
+(require 'cl-lib)
+(require 'filenotify)
+(require 'racket-custom)
+(require 'racket-util)
+(require 'subr-x)
+(require 'tramp)
+
+;; A Racket Mode "back end" is a process running our racket/main.rkt.
+;; The process could be local or (via ssh) remote. The remote process
+;; could even be something like "ssh xvfb-run racket racket/main.rkt".
+;; But for most people it's simply a local process, running on the
+;; same machine as Emacs.
+;;
+;; 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.
+;;
+;; 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.
+
+;; Commands that create buffers that do not visit a file should use
+;; `racket-back-end-name' as a suffix in the buffer name -- enabling a
+;; unique buffer per back end as well as making it easy for users to
+;; distinguish them. See the source for `racket-describe-mode' as an
+;; example.
+
+;; Values for the variable `racket-repl-buffer-name-function' need to
+;; be aware of host names. For example, even
+;; `racket-repl-buffer-name-shared' needs to return different REPL
+;; buffer names for different back end names -- because a REPL on a
+;; back end cannot run files hosted on another.
+
+;; Note: In various places we use `file-remote-p', which, despite the
+;; "-p" isn't just a predicate; it returns the remote prefix before
+;; the localname, expanded.
+;;
+;; Although `file-remote-p' has an optional argument to extract
+;; pieces, only 'localname (and perhaps 'user?) are reliable at least
+;; in Emacs 25. Instead see `racket--back-end-host+user+port'.
+
+;; Note that we disregard the tramp method (if any) for both
+;; `default-directory' and the :directory item for back end
+;; configurations. The user may have used methods like ssh, sshx, scp,
+;; scpx, or rsync with `find-file', and of course tramp will use those
+;; for file transfers for those buffers. But in all cases our back end
+;; process is started using ssh. Example: If the user has one buffer
+;; with ssh method but another buffer with scp method, for the same
+;; host, we do /not/ want two different back ends on that same host,
+;; solely due to those differing methods; nor do we want the user to
+;; need to configure both.
+
+(defvar racket-back-end-configurations nil
+ "A list of property lists, each of which has a unique :directory.
+
+Instead of modifying this directly, users should
+`racket-add-back-end' and `racket-remove-back-end'.")
+
+(defun racket-back-end ()
+ "Return a back end configuration plist for current buffer.
+
+If a configuration does not already exist, automatically add
+one for \"/\" on the host/user/port."
+ (let ((default-directory (racket--file-name-sans-remote-method default-directory)))
+ (or (cl-find default-directory
+ racket-back-end-configurations
+ :test
+ (lambda (dd back-end)
+ ;; This assumes `racket-add-back-end' keeps the
+ ;; list sorted from longest to shortest :directory
+ ;; patterns.
+ (file-in-directory-p dd (plist-get back-end :directory))))
+ (racket-add-back-end (if-let (str (file-remote-p default-directory))
+ (substring-no-properties str)
+ "/")))))
+
+(defun racket-add-back-end (directory &rest plist)
+ "Add a description of a Racket Mode back end.
+
+Racket Mode supports one or more back ends, which are Racket
+processes supporting REPLs as well as various other Racket Mode
+features.
+
+DIRECTORY is a string describing a `file-name-absolute-p'
+directory on some local or remote server.
+
+When a back end's DIRECTORY is the longest matching prefix of a
+buffer's `default-directory', that back end is used for the
+buffer.
+
+DIRECTORY can be a local directory like \"/\" or
+\"/path/to/project\", or a `file-remote-p' directory like
+\"/user@host:\" or \"/user@host:/path/to/project\".
+
+Note that you need not include a method -- such as the \"ssh\" in
+\"/ssh:user@host:\" -- and if you do it is stripped: A back end
+process is always started using SSH. Even if multiple buffers for
+the same user+host+port use different methods, they will share
+the same back end.
+
+Practically speaking, DIRECTORY is a path you could give to
+`find-file' to successfully find some local or remote file, but
+omitting any method. (Some remote file shorthand forms get
+expanded to at least \"/method:host:\". When in doubt check
+`buffer-file-name' and follow its example.)
+
+In addition to being used as a pattern to pick a back end for a
+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).
+
+- Other properties get reasonable defaults based on whether the
+ back end is local or remote, as described below.
+
+After DIRECTORY, the remainining arguments are optional; they are
+alternating :keywords and values describing some other properties
+of a back end:
+
+- :racket-program
+
+ When not nil this is used instead of the value of the
+ customization variable `racket-program'.
+
+- :remote-source-dir
+
+ Where on a remote host to copy the back end's *.rkt files when
+ they do not exist or do not match the digest of the local
+ files. This must be `file-name-absolute-p' on the remote. Only
+ 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
+ front end (which uses slashes even on Windows) and the Racket
+ back end (which expects native backslashes on Windows).
+
+- :restart-watch-directories
+
+ A list of `directory-name-p' strings. Each directory, and
+ recursively its subdirectories, will be watched for file system
+ changes. After any changes are detected, the next
+ `racket-run' (or `racket-run-module-at-point' etc.) command
+ will ask you if it should restart the back end for you. This
+ may be helpful when you are changing source files used by the
+ 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.
+
+ 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'.
+
+Although the default values usually \"just work\" for local and
+remote back ends, you might want a special configuration. Here
+are a few examples.
+
+#+BEGIN_SRC lisp
+ ;; 1. A back end configuration for \"/\" is
+ ;; created automatically and works fine as a default
+ ;; for buffers visiting local files, so we don't need
+ ;; to add one here.
+
+ ;; 2. However assume we want buffers under /var/tmp/8.0
+ ;; instead to use Racket 8.0.
+ (racket-add-back-end \"/var/tmp/8.0\"
+ :racket-program \"~/racket/8.0/bin/racket\")
+
+ ;; 3. A back end configuration will be created
+ ;; automatically for buffers visiting file names like
+ ;; \"/ssh:user@linode\", so we don't need to add one here.
+ ;;
+ ;; If ~/.ssh/config defines a Host alias named \"linode\",
+ ;; with HostName and User settings, a file name as simple as
+ ;; \"/linode:\" would work fine with tramp -- and the
+ ;; automatically created back end configuration would work
+ ;; fine, too.
+
+ ;; 4. For example's sake, assume for buffers visiting
+ ;; /ssh:headless:~/gui-project/ we want :racket-program instead
+ ;; to be \"xvfb-run racket\".
+ (racket-add-back-end \"/ssh:headless:~/gui-project/\"
+ :racket-program \"xvfb-run racket\")
+#+END_SRC
+"
+ (unless (and (stringp directory) (file-name-absolute-p directory))
+ (error "racket-add-back-end: directory must be file-name-absolute-p"))
+ (let* ((local-p (not (file-remote-p directory)))
+ (directory (racket--file-name-sans-remote-method directory))
+ (plist
+ (list
+ :directory directory
+ :racket-program (plist-get plist :racket-program)
+ :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
+ ;; anything".
+ :windows (if (memq :windows plist)
+ (plist-get plist :windows)
+ (and local-p racket--winp)))))
+ (racket--back-end-validate plist)
+ (racket-remove-back-end directory 'no-refresh-watches)
+ ;; Keep configs sorted from longest :directory pattern to shortest.
+ (setq racket-back-end-configurations
+ (sort (cons plist racket-back-end-configurations)
+ (lambda (a b)
+ (> (length (plist-get a :directory))
+ (length (plist-get b :directory))))))
+ (racket--back-end-refresh-watches)
+ plist))
+
+(defun racket--back-end-validate (plist)
+ (cl-flet ((check
+ (type key)
+ (let ((v (plist-get plist key)))
+ (unless (funcall type v)
+ (signal 'wrong-type-argument (list type key v)))))
+ (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))
+ (check #'booleanp :windows)
+ (dolist (dir (plist-get plist :restart-watch-directories))
+ (unless (file-directory-p dir)
+ (signal 'wrong-type-argument (list #'file-directory-p :restart-watch-directories dir)))))
+ plist)
+
+(defun racket-remove-back-end (directory &optional no-refresh-watches-p)
+ (setq racket-back-end-configurations
+ (cl-remove-if (lambda (plist)
+ (and (string-equal (plist-get plist :directory)
+ directory)))
+ racket-back-end-configurations))
+ (unless no-refresh-watches-p
+ (racket--back-end-refresh-watches)))
+
+(defun racket-back-end-name (&optional back-end)
+ "Return the \"name\" of a back end.
+
+This is the back-end :directory. It can be used as suffix to use
+in the name of a buffer not visiting a file. It can also be used
+in situations where you want to refer to the back end indirectly,
+by \"id\" instead of by value."
+ (plist-get (or back-end (racket-back-end)) :directory))
+
+(defun racket--back-end-process-name (&optional back-end)
+ (concat "racket-back-end-" (racket-back-end-name back-end)))
+
+(defun racket--back-end-process-name-stderr (&optional back-end)
+ (concat (racket--back-end-process-name back-end) "-stderr"))
+
+(defun racket--file-name->host+user+port+name (file-name)
+ "Although it would be wonderful simply to use `file-remote-p',
+it is unreliable for \"host\" or \"port\", at least on Emacs 25.
+Instead need the following."
+ (let* ((tfns (and (tramp-tramp-file-p file-name)
+ (tramp-dissect-file-name file-name)))
+ (host (or (and tfns
+ (if (fboundp 'tramp-file-name-real-host)
+ (tramp-file-name-real-host tfns) ;older tramp
+ (tramp-file-name-host tfns)))
+ "127.0.0.1"))
+ (user (and tfns
+ (tramp-file-name-user tfns)))
+ (port (and tfns
+ (let ((p (tramp-file-name-port tfns)))
+ (and (not (equal p 22))
+ p))))
+ (name (or (and tfns
+ (tramp-file-name-localname tfns))
+ file-name)))
+ (list host user port name)))
+
+(defun racket--host+user+port+name->file-name (v)
+ "Like `tramp-make-tramp-file-name' but Emacs version independent."
+ (pcase-let ((`(,host ,user ,port ,localname) v))
+ (let ((port (and port (format "%s" port))))
+ (concat tramp-prefix-format
+ user
+ (unless (zerop (length user))
+ tramp-postfix-user-format)
+ (if (string-match-p tramp-ipv6-regexp host)
+ (concat
+ tramp-prefix-ipv6-format host tramp-postfix-ipv6-format)
+ host)
+ (unless (zerop (length port))
+ (concat tramp-prefix-port-format port))
+ tramp-postfix-host-format
+ localname))))
+
+(defun racket--file-name-sans-remote-method (file-name)
+ (if (file-remote-p file-name)
+ (racket--host+user+port+name->file-name
+ (racket--file-name->host+user+port+name
+ file-name))
+ file-name))
+;;(racket--file-name-sans-remote-method "/ssh:host:/path/to/foo.rkt")
+;;(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))))
+
+(defun racket-file-name-front-to-back (file)
+ "Make a front end file name usable on the back end.
+
+When a remote file name, extract the \"localname\" portion.
+
+When Windows back end, substitute slashes with backslashes."
+ (let* ((file (or (file-remote-p file 'localname)
+ file))
+ (file (if (plist-get (racket-back-end) :windows)
+ (subst-char-in-string ?/ ?\\ file)
+ file)))
+ file))
+
+(defun racket-how-front-to-back (how)
+ "Convenience for back end commands that have a \"how\" argument.
+
+These \"how\" arguments can be a path name, or a pair where the
+car is a path name, or the symbol namespace. Apply
+`racket-file-name-front-to-back' in the path name cases."
+ (pcase how
+ ((and (pred stringp) path)
+ (racket-file-name-front-to-back path))
+ (`(,(and (pred stringp) path) . ,anchor)
+ (cons (racket-file-name-front-to-back path) anchor))
+ (v v)))
+
+(defun racket-file-name-back-to-front (file)
+ "Make a file name from the back end usable on the front end.
+
+When Windows back end, replace back slashes with forward slashes.
+
+When remote back end, treat FILE as the \"localname\" portion of
+a remote file name, and form a remote file name by prepending to
+FILE the back end's remote prefix."
+ (let* ((back-end (racket-back-end))
+ (file (if (plist-get back-end :windows)
+ (subst-char-in-string ?\\ ?/ file)
+ file))
+ (file (if-let (prefix (file-remote-p (plist-get back-end :directory)))
+ (concat (substring-no-properties prefix) file)
+ file)))
+ file))
+
+;;; Tramp remote back end source files
+
+;; Adapted from PR #553 -- for which, big thanks!!
+
+(defun racket--ensure-updated-back-end-on-remote ()
+ "Ensure back end files on remote, return the directory localname.
+
+Take the sha-1 digest for `racket--rkt-source-dir' files. Look
+for a \"digest\" file on the remote. If it doesn't exist or its
+contents don't match, then we copy a new \"digest\" file as well
+as the entire `racket--rkt-source-dir' tree to the remote.
+Otherwise assume the files exist there and are current, from the
+last time we needed to copy.
+
+This is the most efficient way I can think of to handle this over
+a possibly slow remote connection."
+ (let* ((back-end (racket-back-end))
+ (back-end-dir (plist-get back-end :directory))
+ (remote-source-dir (plist-get back-end :remote-source-dir))
+ (tramp-dir (concat (file-remote-p back-end-dir)
+ remote-source-dir))
+ (digest-here
+ (sha1
+ (string-join
+ (mapcar (lambda (file-name)
+ (with-temp-buffer
+ (insert-file-contents-literally file-name)
+ (sha1 (current-buffer))))
+ (directory-files-recursively racket--rkt-source-dir ".+")))))
+ (digest-file-there (expand-file-name "digest" tramp-dir))
+ (digest-there
+ (with-temp-buffer
+ (let ((tramp-verbose 0))
+ (ignore-errors ;OK if it doesn't exist yet
+ (insert-file-contents-literally digest-file-there)))
+ (buffer-substring (point-min) (point-max)))))
+ (unless (equal digest-here digest-there)
+ ;; We need to create a digest file on the remote. The simplest
+ ;; way to do so is create the file locally, then let `copy-file'
+ ;; use tramp automatically.
+ ;;
+ ;; Don't create a digest file in `rkt--source-dir' -- it would
+ ;; be one more thing to .gitignore, and might interfere with
+ ;; people using e.g. straight.el -- instead make a temp file.
+ (let* ((temp-digest-file-here (make-temp-file "racket-mode-digest")))
+ (with-temp-buffer
+ (insert digest-here)
+ (write-region (point-min) (point-max) temp-digest-file-here))
+ (let ((tramp-verbose 2)) ;avoid "encoding"/"decoding" messages
+ ;; Copy the back end directory to the remote.
+ ;;
+ ;;`copy-directory' creates symlinks when the source is a
+ ;; symlink (and e.g. straight.el keeps package repos in a
+ ;; symlinked dir), which won't work on a remote host. Change
+ ;; `make-symbolic-link' to `copy-file' during the dynamic
+ ;; extent of our call to `copy-directory'. Note that
+ ;; `cl-flet' is /not/ the right thing to use here; see e.g.
+ ;; <http://endlessparentheses.com/understanding-letf-and-how-it-replaces-flet.html>
+ (cl-letf (((symbol-function 'make-symbolic-link)
+ (lambda (src dest ok-if-already-exists-p)
+ (copy-file src dest ok-if-already-exists-p nil))))
+ (copy-directory racket--rkt-source-dir
+ tramp-dir
+ nil t t))
+ ;; Now that we're sure the directory there is created, copy
+ ;; our digest file.
+ (copy-file temp-digest-file-here digest-file-there t)
+ (delete-file temp-digest-file-here))
+ (message "Racket Mode back end copied to remote back end at %s"
+ tramp-dir)))
+ remote-source-dir))
+
+(defun racket--back-end-args->command (back-end racket-command-args)
+ "Given RACKET-COMMAND-ARGS, prepend path to racket for BACK-END."
+ (if (racket--back-end-local-p back-end)
+ `(,(or (plist-get back-end :racket-program)
+ (executable-find racket-program)
+ (user-error
+ "Cannot find Racket executable\nracket-program: %S\nexec-path: %S"
+ racket-program
+ exec-path))
+ ,@racket-command-args)
+ (pcase-let ((`(,host ,user ,port ,_name)
+ (racket--file-name->host+user+port+name
+ (plist-get back-end :directory))))
+ `("ssh"
+ ,@(when port
+ `("-p" ,(format "%s" port)))
+ ,(if user
+ (format "%s@%s"
+ user
+ host)
+ host)
+ ,(or (plist-get back-end :racket-program)
+ racket-program) ;can't use `executable-find' remotely
+ ,@racket-command-args))))
+
+;;; File system watches
+
+(defvar racket--back-end-watch-descriptors nil)
+
+(defun racket--back-end-refresh-watches ()
+ ;; Remove all our existing watches.
+ (mapc #'file-notify-rm-watch racket--back-end-watch-descriptors)
+ (setq racket--back-end-watch-descriptors nil)
+ ;; Create new watches.
+ (dolist (plist racket-back-end-configurations)
+ (let ((back-end-dir (plist-get plist :directory)))
+ (dolist (watch-dir (plist-get plist :restart-watch-directories))
+ (dolist (file (cons watch-dir
+ (directory-files-recursively watch-dir ".+" t)))
+ (when (file-directory-p file)
+ (push (file-notify-add-watch (directory-file-name file)
+ '(change)
+ (apply-partially
+ #'racket--back-end-watch-callback
+ back-end-dir))
+ racket--back-end-watch-descriptors)))))))
+
+(defvar racket--back-end-watch-changes (make-hash-table :test #'equal))
+
+(defun racket--back-end-watch-callback (back-end-dir event)
+ (pcase-let ((`(,_descriptor ,action ,file . _more) event))
+ (unless (or (eq action 'stopped)
+ (string-match-p "^[.]#" (file-name-base file)))
+ (puthash back-end-dir
+ (cl-remove-duplicates
+ (cons file (gethash back-end-dir
+ racket--back-end-watch-changes))
+ :test #'equal)
+ racket--back-end-watch-changes))))
+
+(defun racket--back-end-watch-read/reset ()
+ (let ((key (racket-back-end-name)))
+ (prog1
+ (gethash key
+ racket--back-end-watch-changes)
+ (puthash key
+ nil
+ racket--back-end-watch-changes))))
+
+(provide 'racket-back-end)
+
+;; racket-back-end.el ends here
diff --git a/racket-browse-url.el b/racket-browse-url.el
index 77d6bb6..7c194e1 100644
--- a/racket-browse-url.el
+++ b/racket-browse-url.el
@@ -6,22 +6,22 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-custom)
+(require 'racket-cmd)
+(require 'racket-back-end)
(defun racket-browse-url (url &rest args)
(when url
(apply racket-browse-url-function url args)))
+(defun racket-browse-file-url (path anchor)
+ (when (or (file-remote-p path)
+ (not (racket--back-end-local-p)))
+ (user-error "Cannot use web browser to browse remote documentation; instead use `racket-describe'"))
+ (racket-browse-url (concat "file://" path "#" anchor)))
+
(defun racket-browse-url-using-temporary-file (url &rest _args)
"Browse a URL via a temporary HTML file using a meta redirect.
@@ -39,7 +39,7 @@ you do not need to use this. You can customize the variable
`racket-browse-url-function' instead to be `browse-url', or
`browse-url-browser-function' in case have have customized that,
or indeed whatever you want."
- (let* ((url (if (string-match ".*://" url) url (concat "file://" url)))
+ (let* ((url (if (string-match-p ".*://" url) url (concat "file://" url)))
(file (make-temp-file "racket-browse-url-" nil ".html"))
(file-uri (concat "file://" file))
(html (format "<html><head><meta http-equiv=\"refresh\" content=\"0;url=%s\" /></head></html>" url)))
diff --git a/racket-bug-report.el b/racket-bug-report.el
index e6473b4..a010961 100644
--- a/racket-bug-report.el
+++ b/racket-bug-report.el
@@ -1,20 +1,12 @@
;;; racket-bug-report.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
(require 'package)
@@ -36,9 +28,9 @@
(pp (cons '(alist-get 'racket-mode package-alist)
(let ((v (assq 'racket-mode package-alist)))
(and v (cdr v)))))
- (cl-labels ((id-val (id) (list id
- (condition-case () (symbol-value id)
- (error 'UNDEFINED)))))
+ (cl-flet ((id-val (id) (list id
+ (condition-case () (symbol-value id)
+ (error 'UNDEFINED)))))
(pp `(,@(mapcar #'id-val
`(emacs-version
system-type
@@ -84,7 +76,7 @@
(lambda (a b)
(string-lessp (format "%s" (car a))
(format "%s" (car b)))))))
- (cl-labels ((f (x) (list (car x)))) ;car as a list so pp line-wraps
+ (cl-flet ((f (x) (list (car x)))) ;car as a list so pp line-wraps
(pp `(enabled-minor-modes ,@(mapcar #'f (cl-remove-if-not #'cadr sorted))))
(pp `(disabled-minor-modes ,@(mapcar #'f (cl-remove-if #'cadr sorted)))))))
(princ "</pre>\n")
diff --git a/racket-cmd.el b/racket-cmd.el
index 82ec3dd..7af4cb1 100644
--- a/racket-cmd.el
+++ b/racket-cmd.el
@@ -1,169 +1,235 @@
;;; racket-cmd.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
-;; Image portions Copyright (C) 2012 Jose Antonio Ortega Ruiz.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
-;;; Back end command server process
+;;; Back end: process and commands
+(require 'racket-back-end)
(require 'racket-custom)
(require 'racket-util)
+(require 'tramp)
+(require 'cl-lib)
+(require 'seq)
+(require 'subr-x)
(declare-function racket--debug-on-break "racket-debug" (response))
(autoload 'racket--debug-on-break "racket-debug")
-(declare-function racket--logger-on-notify "racket-logger" (str))
+(declare-function racket--logger-on-notify "racket-logger" (back-end-name str))
(autoload 'racket--logger-on-notify "racket-logger")
;;;###autoload
(defvar racket-start-back-end-hook nil
- "Hook run after `racket-start-back-end'.")
+ "Hook run after `racket-start-back-end' finishes successfully.")
+
+;;;###autoload
+(defvar racket-stop-back-end-hook nil
+ "Hook run before `racket-stop-back-end'.")
;;;###autoload
(defun racket-start-back-end ()
- "Start the back end process used by Racket Mode.
+ "Start a back end process used by Racket Mode.
-If the process is already started, this command will stop and restart it.
+If a process is already started, this command will stop and restart it.
-As the final step, runs the hook `racket-start-back-end-hook'."
+When successful runs the hook `racket-start-back-end-hook'."
(interactive)
- (racket--cmd-open)
- (run-hooks racket-start-back-end-hook))
+ (racket--back-end-validate (racket-back-end))
+ (racket--cmd-open))
;;;###autoload
(defun racket-stop-back-end ()
- "Stop the back end process used by Racket Mode.
+ "Stop a back end process used by Racket Mode.
-If the process is not already started, this does nothing."
+Before doing anything runs the hook `racket-stop-back-end-hook'."
(interactive)
(racket--cmd-close))
-(defconst racket--cmd-process-name "racket-mode-back-end"
- "Used to name the process and its associated buffer.")
-
(defun racket--cmd-open-p ()
- "Does a running process exist for the command server?"
- (pcase (get-process racket--cmd-process-name)
+ "Does a running process exist for `racket-back-end-name'?"
+ (pcase (get-process (racket--back-end-process-name (racket-back-end)))
((and (pred (processp)) proc)
(eq 'run (process-status proc)))))
-(defvar racket--run.rkt (expand-file-name "main.rkt" racket--rkt-source-dir)
- "Pathname of run.rkt.")
-
-(defvar racket-adjust-run-rkt #'identity
- "A function used to transform the variable `racket--run.rkt'.
-
-You probably don't need to change this unless you are developing
-Racket Mode, AND run Emacs on Windows Subsystem for Linux, AND
-want to run your programs using Windows Racket.exe, AND have the
-Racket Mode source code under \"/mnt\". Whew. In that case you
-can set this variable to the function `racket-wsl-to-windows' so
-that Racket Mode can find its own run.rkt file.")
+(make-obsolete-variable
+ 'racket-adjust-run-rkt
+ "This is no longer supported."
+ "2021-08-16")
-(defvar racket--cmd-auth nil
- "A value we give the Racket back-end when we launch it and when we create REPLs.
-See issue #327.")
+(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 multiple processes/buffers like "racket-process<1>".
+ ;; Avoid excess processes/buffers like "racket-process<1>".
(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)
((default-value 'exec-path) exec-path))
- (make-process
- :name racket--cmd-process-name
- :connection-type 'pipe
- :noquery t
- :coding 'utf-8
- :buffer (get-buffer-create (concat " *" racket--cmd-process-name "*"))
- :stderr (make-pipe-process
- :name (concat racket--cmd-process-name "-stderr")
- :buffer nil
- :noquery t
- :coding 'utf-8
- :filter #'racket--cmd-process-stderr-filter
- :sentinel #'ignore)
- :command (list racket-program
- (funcall racket-adjust-run-rkt racket--run.rkt)
- "--auth"
- (setq racket--cmd-auth (format "token-%x" (random)))
- (if (and (boundp 'image-types)
- (fboundp 'image-type-available-p)
- (or (and (memq 'svg image-types)
- (image-type-available-p 'svg))
- (and (memq 'imagemagick image-types)
- (image-type-available-p 'imagemagick))))
- "--use-svg"
- "--do-not-use-svg"))
- :filter #'racket--cmd-process-filter)))
+ (let* ((back-end (racket-back-end))
+ (_ (when noninteractive
+ (princ (format "back end is %S\n" back-end))))
+ (process-name (racket--back-end-process-name back-end))
+ (process-name-stderr (racket--back-end-process-name-stderr back-end))
+ (stderr (make-pipe-process
+ :name process-name-stderr
+ :buffer (concat " " process-name-stderr)
+ :noquery t
+ :coding 'utf-8
+ :filter #'racket--cmd-process-stderr-filter
+ :sentinel #'ignore))
+ (local-p (racket--back-end-local-p back-end))
+ (main-dot-rkt (expand-file-name
+ "main.rkt"
+ (if local-p
+ racket--rkt-source-dir
+ (racket--ensure-updated-back-end-on-remote))))
+ (svg-flag (if (and (boundp 'image-types)
+ (fboundp 'image-type-available-p)
+ (or (and (memq 'svg image-types)
+ (image-type-available-p 'svg))
+ (and (memq 'imagemagick image-types)
+ (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))
+ (command (racket--back-end-args->command back-end args))
+ (process
+ (make-process
+ :name process-name
+ :connection-type 'pipe
+ :noquery t
+ :coding 'utf-8
+ :buffer (concat " " process-name)
+ :stderr stderr
+ :command command
+ :filter #'racket--cmd-process-filter
+ :sentinel #'racket--cmd-process-sentinel))
+ (status (process-status process)))
+ (process-put process 'racket-back-end-name (racket-back-end-name back-end))
+ (unless (eq status 'run)
+ (error "%s process status is not \"run\", instead it is %s"
+ process-name
+ status))
+ (run-hooks 'racket-start-back-end-hook))))
(defun racket--cmd-close ()
- (pcase (get-process racket--cmd-process-name)
- ((and (pred (processp)) proc) (delete-process proc)))
- ;; Also kill buffer; helpful in case it contains unread output
- ;; (perhaps because the output was un-read-able, e.g. invalid ELisp
- ;; expression).
- (pcase (get-buffer (concat " *" racket--cmd-process-name "*"))
- ((and (pred (bufferp)) buf) (kill-buffer buf))))
+ "Delete back end's main process/buffer and stderr process/buffer."
+ (cl-flet ((delete-process/buffer
+ (lambda (process-name)
+ (when-let (process (get-process process-name))
+ (when-let (buffer (get-buffer (process-buffer process)))
+ (kill-buffer buffer))
+ (delete-process process)))))
+ (when-let (back-end (racket-back-end))
+ (run-hooks 'racket-stop-back-end-hook)
+ (delete-process/buffer (racket--back-end-process-name back-end))
+ (delete-process/buffer (racket--back-end-process-name-stderr back-end)))))
+
+(defun racket--cmd-process-sentinel (proc event)
+ (when (string-match-p "exited abnormally|failed|connection broken" event)
+ (message "{%s} %s" (process-name proc) (substring event 0 -1))))
(defun racket--cmd-process-stderr-filter (proc string)
"Show back end process stderr via `message'.
-Won't show noise like \"process finished\" if process sentinel is
-`ignore'."
+Won't show noise like \"process finished\" if stderr process
+sentinel is `ignore'."
(message "{%s} %s\n" proc string))
(defun racket--cmd-process-filter (proc string)
- "Parse complete sexprs from the process output and give them to
-`racket--cmd-dispatch-response'."
+ "Read and dispatch sexprs as they become available from process output."
(let ((buffer (process-buffer proc)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(goto-char (point-max))
(insert string)
- (goto-char (point-min))
- (while (pcase (ignore-errors (read buffer))
- (`nil `nil)
- (sexp (delete-region (point-min)
- (if (eq (char-after) ?\n)
- (1+ (point))
- (point)))
- (racket--cmd-dispatch-response sexp)
- t)))))))
+ (racket--cmd-read (apply-partially
+ #'racket--cmd-dispatch
+ (process-get proc 'racket-back-end-name)))))))
+
+;; The process filter inserts text as it arrives in chunks. So the
+;; challenge here is to read whenever the buffer accumulates one or
+;; more /complete/ top-level sexps. Although it's simple to call
+;; `read' and let it succeed or fail, when a top-level sexp is long
+;; (as for check-syntax) and not yet complete, it's wasteful to
+;; read/allocate sub-expressions, only to fail and discard that work
+;; -- perhaps repeatedly as the long sexp grows in the buffer but
+;; remains incomplete. Using `scan-lists' to check for a complete sexp
+;; is better, but still wasteful to do from `point-min' every time.
+;; Instead we use `parse-partial-sexp' to parse/check incrementally,
+;; saving its parse state between calls, and resuming the parse for
+;; newly added text. We tell it to stop when the depth reaches zero,
+;; meaning we have a complete top-level sexp that can be read.
+(defvar-local racket--cmd-read-state nil)
+(defvar-local racket--cmd-read-from 1)
+(defconst racket--cmd-read-whitespace " \n\r\t")
+(defun racket--cmd-read (on-top-level-sexp)
+ ;; Note: Because top-level sexps from the back end are always nested
+ ;; in parens, all we need is a syntax-table to give them that
+ ;; char-syntax, as does even `fundamental-mode'.
+ (while
+ (when (< racket--cmd-read-from (point-max))
+ (setq racket--cmd-read-state
+ (parse-partial-sexp racket--cmd-read-from
+ (point-max)
+ 0 ;target depth
+ nil ;stop before
+ racket--cmd-read-state))
+ (setq racket--cmd-read-from (point))
+ (when (zerop (elt racket--cmd-read-state 0))
+ (goto-char (point-min))
+ (skip-chars-forward racket--cmd-read-whitespace)
+ (when (< (point) (point-max))
+ (funcall on-top-level-sexp (read (current-buffer)))
+ (skip-chars-forward racket--cmd-read-whitespace)
+ (delete-region (point-min) (point))
+ (setq racket--cmd-read-state nil)
+ (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 nonce to callback function.")
+ "A hash from command nonce to callback function.")
(defvar racket--cmd-nonce 0
"Number that increments for each command request we send.")
-(defun racket--cmd-dispatch-response (response)
+(defun racket--cmd-dispatch (back-end response)
"Do something with a sexpr sent to us from the command server.
-Mostly these are responses to command requests. Strictly speaking
-'logger and 'debug-break are \"notifications\", i.e. /not/ one
-direct response to one command request."
+Although mostly these are 1:1 responses to command requests,
+\"logger\" and \"debug-break\" are notifications."
(pcase response
(`(logger ,str)
- (run-at-time 0.001 nil #'racket--logger-on-notify 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))
(`(,nonce . ,response)
- (let ((callback (gethash nonce racket--cmd-nonce->callback)))
- (when callback
- (remhash nonce racket--cmd-nonce->callback)
- (run-at-time 0.001 nil callback response))))
+ (when-let (callback (gethash nonce racket--cmd-nonce->callback))
+ (remhash nonce racket--cmd-nonce->callback)
+ (run-at-time 0.001 nil callback response)))
(_ nil)))
(defun racket--cmd/async-raw (repl-session-id command-sexpr &optional callback)
@@ -193,7 +259,7 @@ form. See `racket--restoring-current-buffer'."
(not (equal callback #'ignore)))
(puthash racket--cmd-nonce callback racket--cmd-nonce->callback))
(process-send-string
- (get-process racket--cmd-process-name)
+ (get-process (racket--back-end-process-name))
(let ((print-length nil) ;for %S
(print-level nil))
(format "%S\n" `(,racket--cmd-nonce ,repl-session-id . ,command-sexpr)))))
@@ -204,10 +270,10 @@ form. See `racket--restoring-current-buffer'."
REPL-SESSION-ID may be nil for commands that do not need to run
in a specific namespace.
-CALLBACK is only called for 'ok responses, with (ok v ...)
+CALLBACK is only called for \"ok\" responses, with (ok v ...)
unwrapped to (v ...).
-'error responses are handled here. Note: We use `message' not
+\"error\" responses are handled here. Note: We use `message' not
`error' here because:
1. It would show \"error running timer:\" which, although true,
@@ -216,30 +282,32 @@ unwrapped to (v ...).
2. More simply, we don't need to escape any call stack, we only
need to ... not call the callback!
-'break responses are handled here, too. This is used when a
+\"break\" responses are handled here, too. This is used when a
command is somehow canceled, with no useful response except the
indication we should clean up the pending callback as usual.
-The original value of `current-buffer' is temporarily restored
-during CALLBACK, because neglecting to do so is a likely
+The original value of `current-buffer' is set for the dynamic
+extent of CALLBACK, because neglecting to do so is a likely
mistake."
- (let ((buf (current-buffer)))
+ (let ((buf (current-buffer))
+ (name (racket--back-end-process-name)))
(racket--cmd/async-raw
repl-session-id
command-sexpr
(if callback
(lambda (response)
(pcase response
- (`(ok ,v) (with-current-buffer buf (funcall callback v)))
- (`(error ,m) (message "%s" m))
+ (`(ok ,v) (when (buffer-live-p buf)
+ (with-current-buffer buf (funcall callback v))))
+ (`(error ,m) (message "%s command exception:\n%s" name m))
(`(break) nil)
(v (let ((print-length nil) ;for %S
(print-level nil))
- (message "Unknown command response: %S" v)))))
+ (message "%s unknown command response:\n%S" name v)))))
#'ignore))))
(defun racket--cmd/await (repl-session-id command-sexpr)
- "Send COMMAND-SEXPR. Await and return an 'ok response value, or raise `error'.
+ "Send COMMAND-SEXPR. Await and return an \"ok\" response value, or raise `error'.
REPL-SESSION-ID may be nil for commands that do not need to run
in a specific namespace."
diff --git a/racket-collection.el b/racket-collection.el
index aa51d01..49affe7 100644
--- a/racket-collection.el
+++ b/racket-collection.el
@@ -1,86 +1,23 @@
;;; racket-collection.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
-(require 'ido)
(require 'tq)
+(require 'racket-back-end)
(require 'racket-repl)
-(require 'racket-complete) ;for `racket--symbol-at-point-or-prompt'
(require 'racket-custom) ;for `racket-program'
(require 'racket-util)
-;;; racket-find-collection
-
-(defun racket-find-collection (&optional prefix)
- "Given a collection name, try to find its directory and files.
-
-Takes a collection name from point.
-
-With \\[universal-argument] prompts you.
-
-If only one directory is found, `ido-find-file-in-dir' lets you
-pick a file there.
-
-If more than one directory is found, `ido-completing-read' lets
-you pick one, then `ido-find-file-in-dir' lets you pick a file
-there.
-
-Note: This requires the `raco-find-collection' package to be
-installed. To install it, in `shell' enter:
-
- raco pkg install raco-find-collection
-
-Tip: This works best with `ido-enable-flex-matching' set to t.
-Also handy is the `flx-ido' package from MELPA.
-
-See also: `racket-open-require-path'."
- (interactive "P")
- (pcase (racket--symbol-at-point-or-prompt prefix "Collection name: ")
- (`() nil)
- (coll
- (racket--cmd/async
- nil
- `(find-collection ,coll)
- (lambda (result)
- (pcase result
- (`()
- (user-error (format "Collection `%s' not found" coll)))
- (`(,path)
- (racket--find-file-in-dir path))
- (paths
- (let ((done nil))
- (while (not done)
- ;; `(ido-find-file-in-dir (ido-completing-read paths))`
- ;; -- except we want to let the user press C-g inside
- ;; ido-find-file-in-dir to back up and pick a different
- ;; module path.
- (let ((dir (ido-completing-read "Directory: " paths)))
- (condition-case ()
- (progn (racket--find-file-in-dir dir)
- (setq done t))
- (quit nil))))))))))))
-
-(defun racket--find-file-in-dir (dir)
- "Like `ido-find-file-in-dir', but allows C-d to `dired' as does `ido-find-file'."
- (ido-file-internal ido-default-file-method nil dir))
-
-
-;;; racket-open-require-path
-
+(define-obsolete-function-alias
+ 'racket-find-collection
+ 'racket-open-require-path
+ "2021-10-15")
;; From looking at ido-mode and ido-vertical-mode:
;;
@@ -118,9 +55,9 @@ See also: `racket-open-require-path'."
(defvar racket--orp/active nil ;;FIXME: Use minibuffer-exit-hook instead?
"Is `racket-open-require-path' using the minibuffer?")
(defvar racket--orp/input ""
- "The current user input. Unless user C-g's this persists, as with DrR.")
+ "The current user input.")
(defvar racket--orp/matches nil
- "The current user matches. Unless user C-g's this persists, as with DrR.")
+ "The current user matches.")
(defvar racket--orp/match-index 0
"The index of the current match selected by the user.")
(defvar racket--orp/max-height 10
@@ -135,22 +72,26 @@ See also: `racket-open-require-path'."
(("SPC" "TAB" "C-v" "<next>" "M-v" "<prior>" "M-<" "<home>" "M->" "<end>")
racket--orp/nop))))
-(defun racket--orp/process ()
+(defun racket--orp/make-process ()
"Start process to run find-module-path-completions.rkt."
- (let ((name "racket-find-module-path-completions-process")
- (buffer " *racket-find-module-path-completions*")
- (stderr " *racket-find-module-path-completions-stderr*")
- (rkt (funcall racket-adjust-run-rkt
- (expand-file-name "find-module-path-completions.rkt"
- racket--rkt-source-dir))))
+ (let* ((back-end (racket-back-end))
+ (name (concat "racket-find-module-path-completions-"
+ (racket-back-end-name back-end)))
+ (rkt-file (expand-file-name "find-module-path-completions.rkt"
+ (if (racket--back-end-local-p back-end)
+ racket--rkt-source-dir
+ (plist-get back-end :remote-source-dir))))
+ (command (racket--back-end-args->command back-end (list rkt-file))))
(make-process :name name
- :buffer buffer
- :command (list racket-program rkt)
:connection-type 'pipe
- :stderr stderr)))
+ :noquery t
+ :coding 'utf-8
+ :buffer (concat " *" name "*")
+ :stderr (concat " *" name "-stderr*")
+ :command command)))
(defun racket--orp/begin ()
- (setq racket--orp/tq (tq-create (racket--orp/process))))
+ (setq racket--orp/tq (tq-create (racket--orp/make-process))))
(defun racket--orp/request-tx-matches (input)
"Request matches from the Racket process; delivered to `racket--orp/rx-matches'."
@@ -164,8 +105,7 @@ See also: `racket-open-require-path'."
(defun racket--orp/rx-matches (buffer answer)
"Completion proc; receives answer to request by `racket--orp/request-tx-matches'."
(when racket--orp/active
- (setq racket--orp/matches (mapcar racket-path-from-racket-to-emacs-function
- (split-string answer "\n" t)))
+ (setq racket--orp/matches (split-string answer "\n" t))
(setq racket--orp/match-index 0)
(with-current-buffer buffer
(racket--orp/draw-matches))))
@@ -192,19 +132,21 @@ at the top, marked with \"->\".
(racket--orp/begin)
(setq racket--orp/active t)
(setq racket--orp/match-index 0)
- ;; We do NOT initialize `racket--orp/input' or `racket--orp/matches'
- ;; here. Like DrR, we remember from last time invoked. We DO
- ;; initialize them in racket--orp/quit i.e. user presses C-g.
+ (setq racket--orp/input "")
+ (setq racket--orp/matches nil)
(add-hook 'minibuffer-setup-hook #'racket--orp/minibuffer-setup)
- (condition-case ()
+ (unwind-protect
(progn
(read-from-minibuffer "Open require path: "
racket--orp/input
- racket--orp/keymap)
+ racket--orp/keymap
+ nil)
(when racket--orp/matches
- (find-file (elt racket--orp/matches racket--orp/match-index))))
- (error (setq racket--orp/input "")
- (setq racket--orp/matches nil)))
+ (find-file (racket-file-name-back-to-front
+ (elt racket--orp/matches racket--orp/match-index)))))
+ (setq racket--orp/input "")
+ (setq racket--orp/matches nil))
+ (remove-hook 'minibuffer-setup-hook #'racket--orp/minibuffer-setup)
(setq racket--orp/active nil)
(racket--orp/end))
diff --git a/racket-common.el b/racket-common.el
index e5a3a5e..c8d76ab 100644
--- a/racket-common.el
+++ b/racket-common.el
@@ -1,25 +1,18 @@
;;; racket-common.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2021 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;; Things used by both racket-mode and racket-repl-mode
-(require 'cl-lib)
+(require 'cl-extra)
(require 'thingatpt)
+(require 'tramp)
(require 'racket-custom)
(require 'racket-keywords-and-builtins)
(require 'racket-font-lock)
@@ -94,7 +87,7 @@
;; char syntax around the "body" so it's treated as a string for
;; indent, nav, font-lock. Think of the \n in #<<ID\n as the open
;; | quote and the \n in ^ID\n as the close | quote.
- ((rx "#<<" (group (+? (not (any blank ?\n)))) (group ?\n))
+ ((rx "#<<" (group (+? (not (any ?\n)))) (group ?\n))
(2 (racket--syntax-propertize-open-here-string
(match-beginning 0)
(match-string-no-properties 1)
@@ -167,7 +160,7 @@ STRING is the actual word used as delimiter (e.g. \"HERE\").
EOL is the position of the \\n.
Point is at the beginning of the next line.
-This sets the open | syntax and sets a 'racket-here-string
+This sets the open | syntax and sets a \"racket-here-string\"
property whose value is STRING. The close | syntax is set by
`racket--syntax-propertize-here-string'."
(unless (save-excursion
@@ -245,7 +238,6 @@ property whose value is STRING. The close | syntax is set by
;; -----------------------------------------------------------------
;; Indent
(setq-local indent-line-function #'racket-indent-line)
- (racket--set-indentation)
(setq-local indent-tabs-mode nil)
;; -----------------------------------------------------------------
;;; Misc
@@ -306,7 +298,7 @@ find the start of a string or comment."
(parse-sexp-ignore-comments t))
(while (ignore-errors
(goto-char (scan-lists (point) -1 1))
- (unless (looking-at racket-module-forms)
+ (unless (looking-at-p racket-module-forms)
(setq pos (point)))
t))
(and pos
@@ -327,13 +319,33 @@ Allows #; to be followed by zero or more space or newline chars."
;;; racket--what-to-run
+(defun racket--what-to-run-p (v)
+ "Predicate for a \"what-to-run\" value.
+
+Either nil or a list, where the first element of the list is a
+file name and the remainder are `symbolp' submodule names.
+
+Note: Because for non-tramp file names this uses `file-exist-p',
+it's good to `racket--save-if-changed' first, ensuring that a
+new buffer has a file on-disk."
+ (pcase v
+ (`() t)
+ (`(,file . ,subs)
+ (and (stringp file)
+ (or (tramp-tramp-file-p file)
+ (file-exists-p file))
+ (cl-every #'symbolp subs)))
+ (_ nil)))
+
(defun racket--what-to-run ()
(cons (racket--buffer-file-name)
(racket--submod-path)))
(defun racket--submod-path ()
- (and (racket--lang-p)
- (racket--modules-at-point)))
+ (let ((mods (racket--modules-at-point)))
+ (if (racket--lang-p)
+ mods
+ (cdr mods))))
(defun racket--lang-p ()
"Is #lang the first sexpr in the file, after an optional shebang?"
@@ -342,11 +354,11 @@ Allows #; to be followed by zero or more space or newline chars."
(ignore-errors
(forward-sexp)
(backward-sexp)
- (when (looking-at (rx "#!"))
+ (when (looking-at-p (rx "#!"))
(forward-line)
(forward-sexp)
(backward-sexp))
- (looking-at (rx "#lang")))))
+ (looking-at-p (rx "#lang")))))
(defun racket--modules-at-point ()
"List of module names that point is within, from outer to inner.
@@ -355,31 +367,32 @@ or syntax quoting, because those won't be valid Racket syntax."
(let ((xs nil))
(condition-case ()
(save-excursion
- (save-match-data
- (racket--escape-string-or-comment)
- (while t
- (when (racket--looking-at-module-form)
- (push (intern (match-string-no-properties 1)) xs))
- (when (racket--looking-at-quoted-form)
- (push nil xs))
- (backward-up-list))))
+ (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)))
(defun racket--looking-at-module-form ()
- "Sets match data group 1 to the module name."
- (looking-at (rx ?\(
- (or "module" "module*" "module+")
- (1+ " ")
- (group (+ (or (syntax symbol)
- (syntax word)
- (syntax punctuation)))))))
-
-(defun racket--looking-at-quoted-form ()
+ "When looking at a module form, return the mod name as a symbol."
+ (save-match-data
+ (when (looking-at (rx ?\(
+ (or "module" "module*" "module+")
+ (1+ " ")
+ (group (+ (or (syntax symbol)
+ (syntax word)
+ (syntax punctuation))))))
+ (intern (match-string-no-properties 1)))))
+
+(defun racket--looking-at-quoted-form-p ()
(or (memq (char-before) '(?\' ?\` ?\,))
(and (eq (char-before (1- (point))) ?\,)
(eq (char-before) ?\@))
- (looking-at
+ (looking-at-p
(rx ?\(
(or "quote" "quasiquote"
"unquote" "unquote-splicing"
@@ -391,18 +404,6 @@ or syntax quoting, because those won't be valid Racket syntax."
;;; Misc
-(defun racket--escape-string-or-comment ()
- "If point is in a string or comment, move to its start.
-
-Note that this can be expensive, as it uses `syntax-ppss' which
-parses from the start of the buffer. Although `syntax-ppss' uses
-a cache, that is invalidated after any changes to the buffer. As
-a result, the worst case would be to call this function after
-every character is inserted to a buffer."
- (pcase (racket--ppss-string/comment-start (syntax-ppss))
- (`() nil)
- (pos (goto-char pos))))
-
(defun racket-backward-up-list ()
"Like `backward-up-list' but works when point is in a string or comment.
diff --git a/racket-company-doc.el b/racket-company-doc.el
new file mode 100644
index 0000000..9df697d
--- /dev/null
+++ b/racket-company-doc.el
@@ -0,0 +1,77 @@
+;;; racket-company-doc.el -*- lexical-binding: t -*-
+
+;; Copyright (c) 2022 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 'seq)
+(require 'shr)
+(require 'racket-back-end)
+(require 'racket-describe)
+(require 'racket-scribble)
+
+(defun racket--company-doc-buffer (how str)
+ (pcase (racket--cmd/await (racket--repl-session-id)
+ `(describe ,(racket-how-front-to-back how) ,str))
+ (`(,(and path (pred stringp)) . ,anchor)
+ (let ((path (racket-file-name-back-to-front path))
+ (name "*racket-company-doc-buffer*"))
+ (when-let (buf (get-buffer name))
+ (when (buffer-live-p buf)
+ (kill-buffer buf)))
+ (with-current-buffer (get-buffer-create name)
+ (goto-char (point-min))
+ (racket--scribble-path+anchor-insert path anchor)
+ (goto-char (point-min))
+ (setq buffer-read-only t)
+ (current-buffer))))))
+
+(defun racket--scribble-path+anchor-insert (path anchor)
+ (with-temp-message (format "Getting and formatting documentation %s %s ..."
+ path anchor)
+ (let* ((tramp-verbose 2) ;avoid excessive messages
+ (dom (racket--html-file->dom path))
+ (body (racket--scribble-body dom))
+ (elems (racket--company-elements-for-anchor body anchor))
+ (dom `(div () ,@elems))
+ (dom (racket--walk-dom dom)))
+ (ignore tramp-verbose)
+ (save-excursion
+ (let ((shr-use-fonts nil)
+ (shr-external-rendering-functions `((span . ,#'racket-render-tag-span)))
+ (shr-width 76)) ;for company-quickhelp-mode
+ (shr-insert-document dom)))
+ (while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
+ (replace-match " " t t)))))
+
+(defun racket--company-elements-for-anchor (xs anchor)
+ "Return the subset of XS dom elements pertaining to ANCHOR."
+ (while (and xs (not (racket--anchored-element (car xs) anchor)))
+ (setq xs (cdr xs)))
+ (and xs
+ (let ((result nil))
+ (push (car xs) result)
+ (setq xs (cdr xs))
+ (while (and xs (not (or (racket--heading-element (car xs))
+ (racket--anchored-element (car xs)))))
+ (push (car xs) result)
+ (setq xs (cdr xs)))
+ (reverse result))))
+
+(defun racket--heading-element (x)
+ (and (listp x)
+ (memq (car x) '(h1 h2 h3 h4 h5 h6))))
+
+(defun racket--anchored-element (x &optional name)
+ (pcase x
+ (`(a ((name . ,a)) . ,_) (or (not name) (equal name a)))
+ (`(,_tag ,_as . ,es) (seq-some (lambda (v) (racket--anchored-element v name))
+ es))))
+
+(provide 'racket-company-doc)
+
+;; racket-company-doc.el ends here
diff --git a/racket-complete.el b/racket-complete.el
index 1911bb8..0ddd08d 100644
--- a/racket-complete.el
+++ b/racket-complete.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-common)
@@ -41,7 +33,7 @@
(condition-case ()
(while (not done)
(backward-up-list)
- (when (looking-at (rx ?\( (or "require" "#%require")))
+ (when (looking-at-p (rx ?\( (or "require" "#%require")))
(setq done t)
(setq result t)))
(scan-error nil))
diff --git a/racket-custom.el b/racket-custom.el
index 2108874..d13e415 100644
--- a/racket-custom.el
+++ b/racket-custom.el
@@ -1,20 +1,12 @@
;;; racket-custom.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; All `defcustom's and `defface's go here.
;;; This makes it easier to provide a consistent UI.
@@ -26,45 +18,35 @@
;; In other words defcustom of racket-foo-bar has a :tag "Foo Bar".
(require 'rx)
-(require 'cl-lib)
(require 'sh-script) ;for sh-heredoc face
+(require 'comint) ;for comint-simple-send in racket-shell-or-terminal
(defgroup racket nil
"Modes for the Racket language."
:group 'languages
:link '(url-link :tag "README on GitHub" "https://github.com/greghendershott/racket-mode/blob/master/README.md"))
-;; This should be _before_ the `defcustom' of `racket-program' (see
-;; note in doc for `define-obsolete-variable-alias').
-(define-obsolete-variable-alias
- 'racket-racket-program
- 'racket-program
- "2017-06-02")
+;; These aliases need be _before_ the `defcustom' of `racket-program'
+;; (see note in doc for `define-obsolete-variable-alias').
+(define-obsolete-variable-alias 'racket-racket-program 'racket-program "2017-06-02")
+(define-obsolete-variable-alias 'racket-raco-program 'racket-program "2017-06-02")
-(make-obsolete-variable
- 'racket-raco-program
- "You need only set `racket-program' to the Racket executable pathname."
- "2017-06-02")
+(defvar racket--winp (eq 'windows-nt system-type))
-(defvar racket--winp (string-match "windows" (symbol-name system-type)))
+(defcustom racket-program (if racket--winp "Racket.exe" "racket")
+ "Pathname of the Racket executable.
-(defcustom racket-program (cond (racket--winp "Racket.exe")
- (t "racket"))
- "Pathname of the racket executable."
+Note that a back end configuration can override this with a
+non-nil `racket-program` property list value. See
+`racket-add-back-end'."
:tag "Racket Program"
:type '(file :must-match t)
:risky t
:group 'racket)
-(make-obsolete-variable
- 'racket-command-port
- "This no longer has any effect. The Racket Mode back end chooses an ephemeral TCP port for REPL sessions and I/O."
- "2020-04-25")
+(make-obsolete-variable 'racket-command-port nil "2020-04-25")
-(make-obsolete-variable
- 'racket-command-startup
- "This no longer has any effect."
- "2020-01-23")
+(make-obsolete-variable 'racket-command-startup nil "2020-01-23")
(defcustom racket-command-timeout 10
"How many seconds to wait for command server responses.
@@ -78,38 +60,9 @@ their response asychronously."
:risky t
:group 'racket)
-(defcustom racket-path-from-emacs-to-racket-function
- #'identity
- "A function to transform Emacs Lisp pathnames given to the Racket back end.
+(make-obsolete-variable 'racket-path-from-emacs-to-racket-function nil "2020-08-26")
-If you run Emacs on Windows Subsystem for Linux, and want to run
-Racket programs using Windows Racket.exe rather than Linux
-racket, you can set this to `racket-wsl-to-windows'. In that case
-you probably also want to customize the \"reverse\":
-`racket-path-from-racket-to-emacs-function'."
- :tag "Path from Emacs to Racket Function"
- :type 'function
- :safe 'functionp
- :group 'racket)
-
-(defcustom racket-path-from-racket-to-emacs-function
- (if racket--winp
- (lambda (path) (subst-char-in-string ?\\ ?/ path))
- #'identity)
- "A function to transform Racket back end pathnames given to Emacs Lisp.
-
-The default on Windows replaces back with forward slashes. The
-default elsewhere is `identity'.
-
-If you run Emacs on Windows Subsystem for Linux, and want to run
-Racket programs using Windows Racket.exe rather than Linux
-racket, you can set this to `racket-windows-to-wsl'. In that case
-you probably also want to customize the \"reverse\":
-`racket-path-from-emacs-to-racket-function'."
- :tag "Path from Racket to Emacs Function"
- :type 'function
- :safe #'functionp
- :group 'racket)
+(make-obsolete-variable 'racket-path-from-racket-to-emacs-function nil "2020-08-26")
(defcustom racket-browse-url-function
'racket-browse-url-using-temporary-file
@@ -125,19 +78,37 @@ you probably also want to customize the \"reverse\":
Where `racket-documentation-search', `racket-xp-documentation'
and `racket-repl-documentation' should look for the search page.
-- If the value of this variable is 'local, open the search page
- from the local documentation, as with \"raco doc\".
+- If the value of this variable is the symbol \"local\", open the
+ search page from the local documentation, as with \"raco doc\".
- Otherwise, the value is a string recognizable by `format', with
- \"%s\" at the point at which to insert the user's search text.
- the help desk. Apart from \"%s\", the string should be a
- properly encoded URL."
- :tag "Where to search documentation"
+ \"%s\" at the point at which to insert the user's search text
+ after applying `url-hexify-string'. Apart from \"%s\", the
+ string should be a properly encoded URL."
+ :tag "Documentation Search Location"
:type '(choice (string :tag "URL")
- (const :tag "Local" 'local))
+ (const :tag "Local" local))
:safe (lambda (val) (or (stringp val) (eq val 'local)))
:group 'racket)
+(defcustom racket-shell-or-terminal-function 'racket-shell
+ "How `racket-racket' and `racket-raco-test' run commands.
+
+The function should accept a command string, not including a
+newline, get or create a suitable buffer, send the command, and
+send a newline or enter.
+
+Predefined choices include `racket-shell', `racket-term',
+`racket-ansi-term', and `racket-vterm'."
+ :tag "Shell or Terminal"
+ :type 'functionp
+ :options '(racket-shell
+ racket-term
+ racket-ansi-term
+ racket-vterm)
+ :safe #'functionp
+ :group 'racket)
+
;;; Xp Mode
(defgroup racket-xp nil
@@ -195,7 +166,7 @@ This is used when a `racket-mode' buffer is created. Changing
this to a new value only affects `racket-mode' buffers created
later.
-Any such function takes no arguments, should look at
+Any such function takes no arguments, should look at the variable
`buffer-file-name' if necessary, and either `setq-default' or
`setq-local' the variable `racket-repl-buffer-name' to a desired
`racket-repl-mode' buffer name. As a result, `racket-run'
@@ -275,10 +246,7 @@ more-helpful error message."
:risky t
:group 'racket-repl)
-(make-obsolete-variable
- 'racket-retry-as-skeleton
- "The motivation for this is now N/A with `racket-xp-mode'."
- "2020-02-26")
+(make-obsolete-variable 'racket-retry-as-skeleton nil "2020-02-26")
(defcustom racket-repl-history-directory
(locate-user-emacs-file (file-name-as-directory "racket-mode"))
@@ -405,11 +373,11 @@ This is safe to set as a file-local variable."
(defcustom racket-indent-sequence-depth 0
"To what depth should `racket-indent-line' search.
-This affects the indentation of forms like '() `() #() --
+This affects the indentation of forms like \\='() \\=`() #() --
and {} if `racket-indent-curly-as-sequence' is t --- but not
-#'() #`() ,() ,@(). A zero value disables, giving the normal
-indent behavior of DrRacket or Emacs `lisp-mode' derived modes
-like `scheme-mode'. Setting this to a high value can make
+#\\='() #\\=`() ,() ,@(). A zero value disables, giving the
+normal indent behavior of DrRacket or Emacs `lisp-mode' derived
+modes like `scheme-mode'. Setting this to a high value can make
indentation noticeably slower. This is safe to set as a
file-local variable."
:tag "Indent Sequence Depth"
@@ -457,23 +425,24 @@ set as a file-local variable."
(module-prefetch . warning)
(optimizer . info)
(racket/contract . error)
+ (racket-mode-debugger . info)
(sequence-specialization . info)
(* . fatal))
"Configuration of `racket-logger-mode' topics and levels.
-The topic '* respresents the default level used for topics not
+The topic \"*\" respresents the default level used for topics not
assigned a level. Otherwise, the topic symbols are the same as
used by Racket's `define-logger`.
-The levels are those used by Racket's logging system: 'debug,
-'info, 'warning, 'error, 'fatal.
+The levels are those used by Racket's logging system: \"debug\",
+\"info\", \"warning\", \"error\", \"fatal\".
For more information see:
<https://docs.racket-lang.org/reference/logging.html>
The default value sets some known \"noisy\" topics to be one
-level quieter. That way you can set the '* topic to a level like
-'debug and not get overhwelmed by these noisy topics."
+level quieter. That way you can set the \"*\" topic to a level
+like \"debug\" and not get overhwelmed by these noisy topics."
:tag "Logger Configuration"
:type '(alist :key-type symbol :value-type symbol)
:safe (lambda (xs)
@@ -481,35 +450,42 @@ level quieter. That way you can set the '* topic to a level like
(and (symbolp (car x))
(symbolp (cdr x))))
xs))
+ :load "racket-cmd"
+ :set (lambda (var val)
+ (set-default var val)
+ (when (fboundp 'racket--logger-activate-config)
+ (racket--logger-activate-config)))
:group 'racket-other)
(defcustom racket-show-functions
(list 'racket-show-pseudo-tooltip)
- "A special hook variable to customize `racket-show'.
+ "An \"abnormal hook\" variable to customize `racket-show'.
-Example functions include:
+This is a list of one or more functions.
- - `racket-show-pseudo-tooltip'
- - `racket-show-echo-area'
- - `racket-show-pos-tip'
- - `racket-show-header-line'
+Each such function must accept two arguments: STR and POS.
-Each function should accept two arguments: VAL and POS.
-
-VAL is:
+STR is one of:
- Non-blank string: Display the string somehow.
- Blank string: Hide any previously displayed string.
- - nil: Hide any persistent UI that might have been created to
- show strings, such as by `racket-show-header-line'.
+ - nil: Hide any persistent UI that might have been created. For
+ instance `racket-show-header-line' hides the header line.
+
+POS may be nil when STR is nil or a blank string.
-POS is the buffer position for which to show the message. It may
-be nil only when VAL is nil or a blank string. When the buffer
-content is a span, POS should be the end of the span. That way,
-for example, a function that shows a tooltip can position it not
-to hide the interesting span in the buffer."
+Otherwise POS is the buffer position -- typically the end of a
+span -- that the non-blank STR describes.
+
+A function that shows STR near POS should position it not to hide
+the span, i.e. below and/or right of POS. Examples:
+`racket-show-pseudo-tooltip' and `racket-show-pos-tip'.
+
+A function that shows STR in a fixed location may of course
+ignore POS. Examples: `racket-show-echo-area' and
+`racket-show-header-line'"
:tag "Racket Show Functions"
:type 'hook
:options '(racket-show-pseudo-tooltip
@@ -574,15 +550,38 @@ to hide the interesting span in the buffer."
"Face for `#:keyword` arguments."
"Keyword Argument Face")
-(define-obsolete-face-alias
- 'racket-paren-face
- "Instead use the `paren-face' package: <https://melpa.org/#/paren-face>."
- "2017-06-13")
+;; Note: Don't use `define-obsolete-face-alias'; see issue #583.
+(defface racket-paren-face nil
+ "This face is unused since 2017-06-13.
+
+Instead customize the face `paren-face', which is provided by the
+optional package `paren-face'.")
-(defface-racket racket-selfeval-face
- '((t (:foreground "SeaGreen")))
- "Face for self-evaluating expressions like numbers, symbols, strings."
- "Selfeval Face")
+;; Note: Don't use `define-obsolete-face-alias'; see issue #583.
+(defface racket-selfeval-face nil
+ "This face is unused since 2021-10-20.
+
+Instead customize the face `font-lock-constant-face'.")
+
+(defface-racket racket-reader-quoted-symbol-face
+ '((t (:inherit font-lock-constant-face)))
+ "Face for symbols quoted using \\=' or \\=`.
+
+This face is given only to symbols directly quoted using the
+reader shorthands \\=' or \\=`. All other directly quoted values,
+including symbols quoted using \"quote\" or \"quasiquote\", get
+the face `font-lock-constant-face'."
+ "Reader Quoted Symbol Face")
+
+(defface-racket racket-reader-syntax-quoted-symbol-face
+ '((t (:inherit default)))
+ "Face for symbols quoted using #\\=' or #\\=`.
+
+This face is given only to symbols directly quoted using the
+reader shorthands #\\=' or #\\=`. All other directly quoted
+values, including symbols quoted using \"syntax\" or
+\"quasisyntax\", get the face `font-lock-constant-face'."
+ "Reader Syntax Quoted Symbol Face")
(defface-racket racket-here-string-face
'((t (:inherit sh-heredoc)))
@@ -629,16 +628,45 @@ to hide the interesting span in the buffer."
"Face for `racket-debug-mode' break position."
"Racket Debug Break Face")
+(defface-racket racket-debug-breakpoint-face
+ '((t (:foreground "red" :weight bold)))
+ "Face for `racket-debug-mode' breakpoint overlays."
+ "Racket Debug Breakpoint Face")
+
(defface-racket racket-debug-locals-face
- '((t (:inherit racket-selfeval-face :box (:line-width -1) :slant italic)))
+ '((t (:inherit font-lock-constant-face :box (:line-width -1) :slant italic)))
"Face for `racket-debug-mode' local variables."
"Racket Debug Locals Face")
(defface-racket racket-debug-result-face
- '((t (:inherit racket-selfeval-face :box (:line-width -1) :slant italic :weight bold)))
+ '((t (:inherit font-lock-constant-face :box (:line-width -1) :slant italic :weight bold)))
"Face for `racket-debug-mode' result values."
"Racket Debug Result Face")
+(defface-racket racket-doc-link-face
+ '((t (:underline (:color "gray" :style line))))
+ "Face `racket-describe-mode' uses for links within documentation.
+Note: When some special face is already specified by the
+documentation, then to avoid visual clutter this face is NOT also
+added."
+ "Racket Doc Link Face")
+
+(defface-racket racket-ext-link-face
+ '((t (:underline (:style wave) :slant italic :weight bold)))
+ "Face `racket-describe-mode' uses for external links.
+See the variable `racket-browse-url-function'."
+ "Racket Ext Link Face")
+
+(defface-racket racket-doc-output-face
+ '((t (:inherit fixed-pitch-serif)))
+ "Face `racket-describe-mode' uses for Scribble @example or @interactions output."
+ "Racket Doc Output Face")
+
+(defface-racket racket-doc-litchar-face
+ '((t (:inherit holiday)))
+ "Face `racket-describe-mode' uses for Scribble @litchar."
+ "Racket Doc Litchar Face")
+
(provide 'racket-custom)
-;; racket-custom.el ends here
+;;; racket-custom.el ends here
diff --git a/racket-debug.el b/racket-debug.el
index 52f41fc..f1328b5 100644
--- a/racket-debug.el
+++ b/racket-debug.el
@@ -1,129 +1,82 @@
;;; racket-debug.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2018-2020 by Greg Hendershott.
+;; Copyright (c) 2018-2022 by Greg Hendershott.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+(require 'racket-back-end)
(require 'racket-repl)
(require 'easymenu)
(require 'cl-lib)
(require 'rx)
-(defun racket-project-files (file-to-run)
+(defun racket-same-directory-files (file)
"A suitable value for the variable `racket-debuggable-files'.
-When projectile is installed and we're in a project, return all
-its Racket files. Else return all Racket files in the same
-directory as `file-to-run'. In all cases, include `file-to-run'.
-In all cases, return absolute path names."
- (cons
- file-to-run
- (or
- (ignore-errors
- (require 'projectile)
- (when (and (fboundp 'projectile-project-root)
- (fboundp 'projectile-dir-files))
- (let ((root (projectile-project-root)))
- (mapcar (lambda (v)
- (expand-file-name v root))
- (cl-remove-if-not (lambda (v)
- (and (member (file-name-extension v)
- '("rkt" "ss" "scm" "scrbl"))
- v))
- (projectile-dir-files root))))))
- (directory-files (file-name-directory file-to-run)
- t
- (rx "." (or "rkt" "ss" "scm" "scrbl") eos)))))
-
-(defvar racket-debuggable-files #'racket-project-files
+Return FILE plus absolute paths for all Racket files in the same
+directory as FILE."
+ (cons file
+ (directory-files (file-name-directory file)
+ t
+ (rx "." (or "rkt" "ss" "scm" "scrbl") eos)
+ nil)))
+
+(defvar racket-debuggable-files #'racket-same-directory-files
"Used to tell `racket-run' what files may be instrumented for debugging.
-Must be a list of strings that are pathnames, such as from
-`racket--buffer-file-name', -or-, a function that returns such a
-list given the pathname of the file being run. If any path
-strings are relative, they are made absolute using
-`expand-file-name' with the directory of the file being run. The
-symbol 'run-file may be supplied in the list; it will be replaced
-with the pathname of the file being run. Safe to set as a
-file-local variable.")
+
+This isn't yet a defcustom becuase the debugger status is still
+\"experimental\".
+
+Must be either a list of file name strings, or, a function that
+takes the name of the file being run and returns a list of file
+names.
+
+Each file name in the list is made absolute using
+`expand-file-name' with respect to the file being run and given
+to `racket-file-name-front-to-back'.")
(defun racket--debuggable-files (file-to-run)
"Do the work described in doc str for variable `racket-debuggable-files'."
- (cl-labels ((err (&rest args)
- (user-error (concat "racket-debuggable-files: must be "
- (apply #'format args)))))
- (let* ((print-length nil) ;for %S
- (print-level nil) ;for %S
- (dir (file-name-directory file-to-run))
- (xs (if (functionp racket-debuggable-files)
- (funcall racket-debuggable-files file-to-run)
- racket-debuggable-files))
- (xs (if (listp xs) xs (err "a list but is `%S'" xs)))
- (xs (mapcar
- (lambda (v)
- (pcase v
- (`run-file file-to-run)
- ((pred stringp) (expand-file-name v dir))
- (_ (err "string or 'run-file but is `%S' in `%S'"
- v xs))))
- xs))
- (xs (if (eq system-type 'windows-nt)
- (mapcar
- (lambda (v)
- (replace-regexp-in-string (rx "/") "\\" v nil t))
- xs)
- xs)))
- xs)))
-
-(defvar racket--debug-break-positions nil)
+ (mapcar (lambda (file)
+ (racket-file-name-front-to-back
+ (expand-file-name file file-to-run)))
+ (if (functionp racket-debuggable-files)
+ (funcall racket-debuggable-files file-to-run)
+ racket-debuggable-files)))
+
+(defvar racket--debug-breakable-positions nil)
(defvar racket--debug-break-locals nil)
(defvar racket--debug-break-info nil)
;; (U nil (cons break-id
;; (U (list 'before)
;; (list 'after string-of-racket-write-values))))
-;;;###autoload
-(defun racket--debug-send-definition (beg end)
- (racket--cmd/async
- (racket--repl-session-id)
- (save-excursion
- (goto-char beg)
- (list 'debug-eval
- (racket--buffer-file-name)
- (line-number-at-pos)
- (current-column)
- (point)
- (buffer-substring-no-properties (point) end)))
- (lambda (_)
- ;; TODO: Also set fringe, and/or set marker on function
- ;; name to show it's debuggable.
- (message "Now you can call the function in the REPL to step debug it."))) )
+(defvar racket--debug-breakpoints nil
+ "A list of overlays for breakpoints the user has set.")
;;;###autoload
(defun racket--debug-on-break (response)
(pcase response
- (`((,src . ,pos) ,positions ,locals ,vals)
- (pcase (find-buffer-visiting src)
- (`nil (other-window 1) (find-file src))
- (buf (pop-to-buffer buf)))
- (goto-char pos)
- (pcase vals
- (`(,_id before) (message "Break before expression"))
- (`(,_id after (,_ . ,s)) (message "Break after expression: (values %s"
- (substring s 1))))
- (setq racket--debug-break-positions positions)
- (setq racket--debug-break-locals locals)
- (setq racket--debug-break-info vals)
- (racket-debug-mode 1))))
+ (`((,src . ,pos) ,breakable-positions ,locals ,vals)
+ (let ((src (racket-file-name-back-to-front src)))
+ (pcase (find-buffer-visiting src)
+ (`nil (other-window 1) (find-file src))
+ (buf (pop-to-buffer buf)))
+ (goto-char pos)
+ (pcase vals
+ (`(,_id before) (message "Break before expression"))
+ (`(,_id after (,_ . ,s)) (message "Break after expression: (values %s"
+ (substring s 1))))
+ (setq racket--debug-breakable-positions
+ (mapcar (lambda (path+positions)
+ (cons (racket-file-name-back-to-front (car path+positions))
+ (sort (cdr path+positions) #'<)))
+ breakable-positions))
+ (setq racket--debug-break-locals locals)
+ (setq racket--debug-break-info vals)
+ (racket-debug-mode 1)))))
(defun racket--debug-resume (next-break value-prompt-p)
(unless racket--debug-break-info (user-error "Not debugging"))
@@ -133,7 +86,7 @@ file-local variable.")
(racket--cmd/async (racket--repl-session-id)
`(debug-resume (,next-break ,info))))
(racket-debug-mode -1)
- (setq racket--debug-break-positions nil)
+ (setq racket--debug-breakable-positions nil)
(setq racket--debug-break-locals nil)
(setq racket--debug-break-info nil))
@@ -150,29 +103,61 @@ file-local variable.")
(v v)))
(defun racket-debug-step (&optional prefix)
- "Resume to next breakable position. With \\[universal-argument] substitute values."
+ "Step to next breakable position. With \\[universal-argument] substitute values."
(interactive "P")
(racket--debug-resume 'all prefix))
(defun racket-debug-step-over (&optional prefix)
- "Resume over next expression. With \\[universal-argument], substitute values."
+ "Step over next expression. With \\[universal-argument], substitute values."
(interactive "P")
(racket--debug-resume 'over prefix))
(defun racket-debug-step-out (&optional prefix)
- "Resume out. With \\[universal-argument], substitute values."
+ "Step out. With \\[universal-argument], substitute values."
(interactive "P")
(racket--debug-resume 'out prefix))
(defun racket-debug-continue (&optional prefix)
- "Resume; don't break anymore. With \\[universal-argument], substitute values."
+ "Continue to next breakpoint. With \\[universal-argument], substitute values."
+ (interactive "P")
+ (racket--debug-validate-breakpoints)
+ (racket--debug-resume (seq-map (lambda (o)
+ (list (with-current-buffer (overlay-buffer o)
+ (racket-file-name-front-to-back
+ (racket--buffer-file-name)))
+ (overlay-start o)
+ (or (overlay-get o 'racket-breakpoint-condition)
+ "#t")
+ (or (overlay-get o 'racket-breakpoint-actions)
+ "(break)")))
+ racket--debug-breakpoints)
+ prefix))
+
+(defun racket--debug-validate-breakpoints ()
+ "Remove invalid overlays from the list."
+ (setq racket--debug-breakpoints
+ (seq-filter (lambda (o)
+ (if (bufferp (overlay-buffer o))
+ t
+ (delete-overlay o)
+ nil))
+ racket--debug-breakpoints)))
+
+(defun racket-debug-go (&optional prefix)
+ "Go, don't break anymore. With \\[universal-argument], substitute values."
(interactive "P")
(racket--debug-resume 'none prefix))
(defun racket-debug-run-to-here (&optional prefix)
"Resume until point (if possible). With \\[universal-argument], substitute values."
(interactive)
- (racket--debug-resume (cons (racket--buffer-file-name) (point)) prefix))
+ ;; i.e. Act as if the only breakpoint is here.
+ (racket--debug-resume (list (list (racket-file-name-front-to-back
+ (racket--buffer-file-name))
+ (point)
+ "#t"
+ "(break)"))
+ prefix))
(defun racket-debug-next-breakable ()
"Move point to next breakable position."
@@ -185,20 +170,121 @@ file-local variable.")
(racket--debug-goto-breakable nil))
(defun racket--debug-goto-breakable (forwardp)
- (pcase (assoc (racket--buffer-file-name) racket--debug-break-positions)
+ (pcase (assoc (racket--buffer-file-name) racket--debug-breakable-positions)
(`(,_src . ,ps)
(let ((ps (if forwardp ps (reverse ps)))
(pred (apply-partially (if forwardp #'< #'>) (point))))
- (goto-char (pcase (cl-find-if pred ps)
- (`nil (car ps))
- (v v)))))
+ (goto-char (or (cl-find-if pred ps) (car ps)))))
(_ (user-error "No breakable positions in this buffer"))))
+(defun racket--debug-breakpoint-overlay-equal (o)
+ (and (equal (overlay-buffer o) (current-buffer))
+ (equal (overlay-start o) (point))))
+
+(defvar racket-debug-breakpoint-conditions '("#t"))
+(defvar racket-debug-breakpoint-actions '("(break)" "(print)" "(log)"))
+(defun racket-debug-toggle-breakpoint ()
+ "Add or remove a breakpoint.
+
+Each breakpoint has a condition and a list of actions.
+
+The condition is a Racket expression that is evaluated in a
+context where local variables exist. Examples:
+
+ - \"#t\" means break always.
+
+ - If the code around the breakpoint is something like
+ \"(for ([n 100]) _)\", then a condition like
+ \"(zero? (modulo n 10))\" is every 10 times through the
+ loop.
+
+Actions is a list of symbols; you may specify one or more. The
+action symbols are:
+
+ - \"break\" causes a break, enabling `racket-debug-mode'.
+
+ - \"log\" and \"print\" display information about local
+ variables to the logger or REPL output, respectively.
+ Although `racket-debug-mode' already shows these values \"in
+ situ\" when you reach a break, this may be useful if you want
+ a history. Specifying \"log\" or \"print\", but not
+ \"break\", is equivalent to what many debuggers call a
+ watchpoint instead of a breakpoint: Output some information
+ and automatically resume.
+
+Note: Although `racket-debug-mode' provides a convenient
+keybinding, you may invoke this command anytime using M-x.
+
+Note: If you're warned that point isn't known to be a breakable
+position, that might be because it truly isn't, or, just because
+you are not in `racket-debug-mode' and the breakable positions
+aren't yet known. Worst case, if you set a breakpoint someplace
+that is not breakable, it is ignored. With a few exceptions --
+such as close paren positions that are tail calls -- most open
+parens and close parens are breakble positions."
+ (interactive)
+ (if-let (o (seq-find #'racket--debug-breakpoint-overlay-equal
+ racket--debug-breakpoints))
+ (progn
+ (delete-overlay o)
+ (setq racket--debug-breakpoints
+ (seq-remove #'racket--debug-breakpoint-overlay-equal
+ racket--debug-breakpoints)))
+ (when (or (pcase (assoc (racket--buffer-file-name) racket--debug-breakable-positions)
+ (`(,_src . ,ps) (memq (point) ps)))
+ (y-or-n-p "Point not known to be a breakable position; set anyway "))
+ (let* ((condition (read-string "Condition expression [RET for \"#t\"]: "
+ nil
+ 'racket-debug-breakpoint-conditions
+ "#t"))
+ (actions (read-string "Actions list [RET for \"(break)\"]: "
+ nil
+ 'racket-debug-breakpoint-actions
+ "(break)"))
+ (o (make-overlay (point) (1+ (point)) (current-buffer) t nil)))
+ (overlay-put o 'name 'racket-debug-breakpoint)
+ (overlay-put o 'before-string (propertize
+ "⦿"
+ 'face 'racket-debug-breakpoint-face))
+ (overlay-put o 'evaporate t)
+ (overlay-put o 'racket-breakpoint-condition condition)
+ (overlay-put o 'racket-breakpoint-actions actions)
+ (push o racket--debug-breakpoints)
+ (setq racket-debug-breakpoint-conditions
+ (seq-uniq racket-debug-breakpoint-conditions))
+ (setq racket-debug-breakpoint-actions
+ (seq-uniq racket-debug-breakpoint-actions))))))
+
+(defun racket-debug-next-breakpoint ()
+ "Move point to the next breakpoint in this buffer."
+ (interactive)
+ (racket--goto-breakpoint 'next))
+
+(defun racket-debug-prev-breakpoint ()
+ "Move point to the previous breakpoint in this buffer."
+ (interactive)
+ (racket--goto-breakpoint 'previous))
+
+(defun racket--goto-breakpoint (dir)
+ (if-let (p (seq-find (if (eq dir 'next)
+ (lambda (pos) (< (point) pos))
+ (lambda (pos) (< pos (point))))
+ (sort (seq-map #'overlay-start
+ (seq-filter (lambda (o)
+ (equal (overlay-buffer o)
+ (current-buffer)))
+ racket--debug-breakpoints))
+ (if (eq dir 'next)
+ #'<
+ #'>))))
+ (goto-char p)
+ (user-error (format "No %s breakpoint in this buffer" dir))))
+
(defun racket-debug-disable ()
(interactive)
(racket--cmd/async (racket--repl-session-id) `(debug-disable))
(racket-debug-mode -1)
- (setq racket--debug-break-positions nil)
+ (setq racket--debug-breakable-positions nil)
(setq racket--debug-break-locals nil)
(setq racket--debug-break-info nil))
@@ -221,51 +307,21 @@ turns out to have too little value and/or too much cost.
How to debug:
-1. \"Instrument\" code for step debugging. You can instrument
- entire files, and also individual functions.
-
- a. Entire Files
+1. \"Instrument\" code for step debugging.
- Use two \\[universal-argument] command prefixes for either
- `racket-run' or `racket-run-module-at-point'.
+ Use two \\[universal-argument] command prefixes for either
+ `racket-run' or `racket-run-module-at-point'.
- The file will be instrumented for step debugging before it
- is run. Also instrumented are files determined by the
- variable `racket-debuggable-files'.
+ The file will be instrumented for step debugging before it is
+ run. Any imported files are also instrumented if they are in
+ the variable `racket-debuggable-files'.
- The run will break at the first breakable position.
+ The run will break at the first breakable position.
- Tip: After you run to completion and return to a normal
- REPL prompt, the code remains instrumented. You may enter
- expressions that evaluate instrumented code and it will
- break so you can step debug again.
-
- b. Function Definitions
-
- Move point inside a function definition form and use
- \\[universal-argument] \\[racket-send-definition] to
- \"instrument\" the function for step debugging. Then in the
- REPL, enter an expression that causes the instrumented
- function to be run, directly or indirectly.
-
- You can instrument any number of functions.
-
- You can even instrument while stopped at a break. For
- example, to instrument a function you are about to call, so
- you can \"step into\" it:
-
- - \\[racket-xp-visit-definition] to visit the definition.
- - \\[universal-argument] \\[racket-send-definition] to instrument the definition.
- - \\[racket-unvisit] to return.
- - Continue stepping.
-
- Limitation: Instrumenting a function required from another
- module won't redefine that function. Instead, it attempts
- to define an instrumented function of the same name, in the
- module the REPL is inside. The define will fail if it needs
- definitions visible only in that other module. In that case
- you'll probably need to use entire-file instrumentation as
- described above.
+ Tip: After you run to completion and return to a normal
+ REPL prompt, the code remains instrumented. You may enter
+ expressions that evaluate instrumented code and it will
+ break so you can step debug again.
2. When a break occurs, the `racket-repl-mode' prompt changes. In
this debug REPL, local variables are available for you to use
@@ -285,8 +341,12 @@ How to debug:
("o" racket-debug-step-over)
("u" racket-debug-step-out)
("c" racket-debug-continue)
+ ("g" racket-debug-go)
("n" racket-debug-next-breakable)
("p" racket-debug-prev-breakable)
+ ("N" racket-debug-next-breakpoint)
+ ("P" racket-debug-prev-breakpoint)
+ ("!" racket-debug-toggle-breakpoint)
("h" racket-debug-run-to-here)
("?" racket-debug-help)))
(unless (eq major-mode 'racket-mode)
@@ -329,4 +389,3 @@ How to debug:
(provide 'racket-debug)
;; racket-debug.el ends here
-
diff --git a/racket-describe.el b/racket-describe.el
index b298fce..e574d58 100644
--- a/racket-describe.el
+++ b/racket-describe.el
@@ -1,125 +1,463 @@
;;; racket-describe.el -*- lexical-binding: t -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'shr)
(require 'subr-x)
+(require 'racket-browse-url)
(require 'racket-cmd)
(require 'racket-util)
(require 'racket-visit)
+(require 'racket-scribble)
+(require 'racket-browse-url)
+(require 'racket-back-end)
;; Don't (require 'racket-repl). Mutual dependency. Instead:
-(declare-function 'racket--repl-session-id "racket-repl")
+(declare-function racket--repl-session-id "racket-repl" ())
(autoload 'racket--repl-session-id "racket-repl")
-(defun racket--do-describe (how
- repl-session-id
- str
- &optional
- display-and-pop-to-p
- visit-thunk
- doc-thunk)
- "Create a `racket-describe-mode' buffer.
-
-HOW is supplied as the first argument to the back-end
-\"describe\" command. See it for details that we don't need to
-know or care about in this function.
-
-STR is the string form of an identifier that is to be described.
-
-DISPLAY-AND-POP-TO-P should be t for use by direct user commands
-like `racket-xp-describe' and `racket-repl-describe' -- in which
-the buffer is displayed -- and nil for use as
-a :company-doc-buffer function.
-
-VISIT-THUNK and DOC-THUNK are, when not nil, used to insert
-\"Visit Definition\" and \"Documentation in Browser\" buttons.
-
-Returns the buffer in which the description was written."
- ;; Work around what seems to be a bug with `shr-insert-document' --
- ;; elements are out of order when an existing Racket Describe buffer
- ;; hasn't had a `quit-window' -- by re-creating the buffer.
- (with-current-buffer (racket--get-buffer-recreate "*Racket Describe*")
- (let* ((html (racket--cmd/await repl-session-id
- `(describe ,how ,str)))
- ;; Because shr removes leading from <td> elements --
- ;; which messes up the indentation of s-expressions
- ;; including contracts -- replace   with `spc' in the
- ;; source HTML. Below we'll replace `spc' with " " in the
- ;; result of `shr-insert-document'.
- (spc (string #x2020)) ;unlikely character (hopefully)
- (dom (with-temp-buffer
- (insert html)
- (goto-char (point-min))
- (while (re-search-forward " " nil t)
- (replace-match spc t t))
- (libxml-parse-html-region (point-min) (point-max)))))
- (racket-describe-mode)
- (read-only-mode -1)
- (let ((shr-use-fonts nil))
- (shr-insert-document dom))
- (goto-char (point-min))
- (while (re-search-forward spc nil t)
- (replace-match " " t t))
- (when display-and-pop-to-p
- (goto-char (point-max))
- (insert "\n")
- (when visit-thunk
- (insert-text-button "Visit Definition"
- 'follow-link t
- 'action
- (lambda (_btn) (funcall visit-thunk)))
- (insert " "))
- (when doc-thunk
- (insert-text-button "Documentation in Browser"
- 'follow-link t
- 'action
- (lambda (_btn) (funcall doc-thunk))))
- (insert " [q]uit"))
- (read-only-mode 1)
- (goto-char (point-min))
- (when display-and-pop-to-p
- (display-buffer (current-buffer) t)
- (pop-to-buffer (current-buffer))
- (message "Type TAB to move to links, 'q' to restore previous window"))
- (current-buffer))))
+(defvar-local racket--describe-here nil
+ "The current navigation point. Either nil or (cons path point).")
+(defvar-local racket--describe-stack-back nil
+ "Back navigation list. Each item is (cons path point).")
+(defvar-local racket--describe-stack-forward nil
+ "Forward navigation list. Each item is (cons path point).")
+
+(defun racket--do-describe (how repl-session-id str)
+ "Get or create a `racket-describe-mode' buffer and display it.
+
+HOW is somewhat complicated, due to this function being
+overloaded to handle both showing documentation for an
+already-known path and anchor (e.g. from `racket-xp-mode') as
+well as seeing if STR is an identifier in a namespace for which
+we can find documentation, or least return a description of its
+signature and/or type. So:
+
+- When HOW is (cons path anchor) we load/show that documentation,
+ and ignore STR. We don't issue a back end command. (Earlier
+ versions of Racket Mode used the back end to fetch the HTML or
+ shr-dom, but these days we do it all in the front end.)
+ REPL-SESSION-ID and STR are unused and may be nil.
+
+- When HOW is \"namespace\" or a stringp pathname, we use that as
+ the namespace in which to see if STR is an identifier, using
+ the \"describe\" back end command. The command can return a few
+ kinds of values; see the implementation below. When HOW is
+ \"namespace\" then REPL-SESSION-ID should be
+ `racket--repl-session-id'; else may be nil."
+ (let ((buf-name (format "*Racket Describe <%s>*"
+ (racket-back-end-name))))
+ (with-current-buffer (get-buffer-create buf-name)
+ (unless (eq major-mode 'racket-describe-mode)
+ (racket-describe-mode))
+ (racket--describe-maybe-push-here 'back) ;do before erasing buffer
+ (setq racket--describe-stack-forward nil)
+ (let ((buffer-read-only nil))
+ (erase-buffer))
+ ;; shr-insert-document seems to misbehave when buffer has no
+ ;; window so do this early.
+ (pop-to-buffer (current-buffer))
+ (pcase how
+ ;; If HOW is the doc path and anchor (the latter can be nil),
+ ;; there's no need to issue a back end describe command.
+ (`(,(and path (pred stringp)) . ,anchor)
+ (racket--describe-insert-dom path
+ anchor
+ (racket--scribble-path->shr-dom path)))
+ ;; If HOW is a string pathname or 'namspace, then we need to
+ ;; use the back end describe command. It returns one of three
+ ;; kinds of values.
+ ((guard (or (stringp how) (eq how 'namespace)))
+ (setq header-line-format
+ (propertize (format "Getting information from back end about %s ..." str)
+ 'face 'italic))
+ (racket--cmd/async
+ repl-session-id
+ `(describe ,(racket-how-front-to-back how) ,str)
+ (lambda (result)
+ (pcase result
+ ;; STR has documentation at path and anchor. Handle like
+ ;; the case where we knew the path and anchor up-front.
+ (`(,(and path (pred stringp)) . ,anchor)
+ (let ((path (racket-file-name-back-to-front path)))
+ (racket--describe-insert-dom path
+ anchor
+ (racket--scribble-path->shr-dom path))))
+ ;; STR doesn't have documentation, but it does have a
+ ;; signature and/or type, and here is a dom about that
+ ;; we can insert.
+ (`(shr-dom ,dom)
+ (racket--describe-insert-dom nil ;path
+ str ;anchor
+ dom))
+ ;; STR doesn't seem to be an identifier we can describe.
+ (`()
+ (racket--describe-insert-dom nil ;path
+ str ;anchor
+ (racket--describe-not-found-dom str)))))))
+ (_ (error "Bad value for `how`: %s" how))))))
+
+(defun racket--describe-not-found-dom (str)
+ `(div ()
+ (p ()
+ "No documentation, signature, or type found for "
+ (racket-anchor ((name . ,str)))
+ (em () ,str))
+ (p () "If you came from a racket-xp-mode buffer, maybe it didn't finish annotating. You could press " (strong () "q") " return to that buffer, wait, then try again.")
+ (p () "Otherwise you can type " (strong () "C-c C-s") " to search for " (em () ,str) " in the documentation index.")))
+
+(defvar-local racket--describe-nav nil
+ "The value of the racket-nav element extracted from a page.
+Use `dom-attr' to extract the top, up, prev, next links, if any.")
+
+(defun racket--describe-insert-dom (path goto dom)
+ "Insert DOM into current buffer, add some buttons, and move point.
+
+GOTO determines where point is moved: If stringp move to that
+anchor. If numberp, move to that position."
+ (setq racket--describe-here
+ (if path (cons path goto) nil))
+ (setq racket--describe-nav nil)
+ (setq header-line-format
+ (propertize
+ (concat path (cond ((stringp goto) (concat " " goto))
+ ((numberp goto) (format " %s" goto))))
+ 'face '(:height 0.75)))
+ (cl-macrolet ((disable (id) `(and (boundp ',id) ,id (fboundp ',id) (,id -1))))
+ (disable linum-mode)
+ (disable display-line-numbers-mode))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((shr-use-fonts nil)
+ (shr-external-rendering-functions
+ `((span . ,#'racket-render-tag-span)
+ (h1 . ,#'racket-render-tag-heading)
+ (h2 . ,#'racket-render-tag-heading)
+ (h3 . ,#'racket-render-tag-heading)
+ (h4 . ,#'racket-render-tag-heading)
+ (h5 . ,#'racket-render-tag-heading)
+ (h6 . ,#'racket-render-tag-heading)
+ (h7 . ,#'racket-render-tag-heading)
+ (racket-doc-link . ,#'racket-render-tag-racket-doc-link)
+ (racket-ext-link . ,#'racket-render-tag-racket-ext-link)
+ (racket-anchor . ,#'racket-render-tag-racket-anchor)
+ (racket-nav . ,#'racket-render-tag-racket-nav))))
+ (shr-insert-document dom))
+ ;; See doc string for `racket--scribble-temp-nbsp'.
+ (goto-char (point-min))
+ (while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
+ (replace-match " " t t))
+ (racket--describe-goto goto)))
+
+(defun racket--describe-goto (goto)
+ "Move point to GOTO.
+
+If `numberp', move to that position.
+
+If `stringp' move to the position after the anchor that is not
+anchor. There could be multiple anchors before some non-anchor
+text. We want point left where `racket-search-describe' can use
+`thing-at-point' to find a symbol."
+ (set-window-point ;in case buffer window isnt' selected; #590
+ (get-buffer-window (current-buffer))
+ (cond
+ ((numberp goto)
+ goto)
+ ((stringp goto)
+ (or (let ((i nil)) ;silence byte-compiler warning
+ (cl-loop for i being the intervals
+ if (equal (get-text-property (car i) 'racket-anchor)
+ goto)
+ return (cl-loop for j from (car i) to (point-max)
+ if (not (get-text-property j 'racket-anchor))
+ return j)))
+ (point-min)))
+ (t (point-min))))
+ (setq racket--describe-here
+ (cons (car racket--describe-here) (point))))
+
+(defconst racket--shr-faces
+ '(("RktSym" . font-lock-keyword-face)
+ ("RktVal" . font-lock-constant-face)
+ ("RktCmt" . font-lock-comment-face)
+ ("RktErr" . error)
+ ("RktOut" . racket-doc-output-face)
+ ("RktRes" . font-lock-constant-face)
+ ("RktVar" . font-lock-variable-name-face)
+ ("RktInBG" . racket-doc-litchar-face)
+ ("RktModLink" . font-lock-keyword-face)
+ ("techinside" . italic)
+ ("RktValLink" . font-lock-variable-name-face)
+ ("RktStxLink" . font-lock-keyword-face)
+ ("RktValDef RktValLink" . bold)
+ ("RktStxDef RktStxLink" . bold)))
+
+(defun racket--describe-dom->face (dom)
+ (let ((class (dom-attr dom 'class)))
+ (if (equal class "RktPn")
+ ;; Scribble gives keyword arguments "RktPn" style and CSS
+ ;; conditionally adjusts. Ugh. Do similar hack here.
+ (cond ((string-match-p "^#:" (dom-text dom)) 'racket-keyword-argument-face)
+ ((facep 'parenthesis) 'parenthesis)
+ (t 'default))
+ (cdr (assoc class racket--shr-faces)))))
+
+(defun racket-render-tag-span (dom)
+ "Handle some things shr-tag-span does not.
+
+When span has a title attribute, set help-echo property.
+
+When span has a RktXXX or techinside class, set the face."
+ (let ((start (point)))
+ (if-let (face (racket--describe-dom->face dom))
+ (shr-fontize-dom dom face)
+ (shr-generic dom))
+ (when-let (title (dom-attr dom 'title))
+ (put-text-property start (point) 'help-echo title))))
+
+(defconst racket--shr-headings
+ '((h1 (variable-pitch (:height 2.00)))
+ (h2 (variable-pitch (:height 1.90)))
+ (h3 (variable-pitch (:height 1.75)))
+ (h4 (variable-pitch (:height 1.60)))
+ (h5 (variable-pitch (:height 1.45)))
+ (h6 (variable-pitch (:height 1.40)))
+ (h7 (variable-pitch (:height 1.15)))))
+
+(defun racket-render-tag-heading (dom)
+ (let* ((tag (car dom))
+ (face (or (when-let (v (assq tag racket--shr-headings))
+ (cadr v))
+ `(variable-pitch (:weight bold)))))
+ (shr-heading dom face)))
+
+(define-button-type 'racket-doc-link
+ 'action #'racket-describe-doc-link-button)
+
+(defun racket-render-tag-racket-doc-link (dom)
+ (let ((path (dom-attr dom 'path))
+ (anchor (dom-attr dom 'anchor))
+ (start (point))
+ (shr-start nil))
+ (shr-generic dom) ;this will add faces to `dom' kids
+ (unless (= start (point))
+ (make-text-button
+ start (point)
+ 'type 'racket-doc-link
+ 'racket-doc-link-path path
+ 'racket-doc-link-anchor anchor
+ 'face 'racket-doc-link-face))))
+
+(define-button-type 'racket-ext-link
+ 'action #'racket-describe-ext-link-button)
+
+(defun racket-render-tag-racket-ext-link (dom)
+ (let ((href (dom-attr dom 'href))
+ (start (point))
+ (shr-start nil))
+ (shr-generic dom)
+ (unless (= start (point))
+ (make-text-button
+ start (point)
+ 'type 'racket-ext-link
+ 'face 'racket-ext-link-face
+ 'racket-ext-link-href href))))
+
+(defun racket-render-tag-racket-anchor (dom)
+ "At least in Emacs 25.2 shr-tag-a isn't handling <a> anchors at all.
+So we have our back end substitute these <racket-anchor> elements
+for our custom shr handler."
+ (let ((start (point))
+ (id (or (dom-attr dom 'id) (dom-attr dom 'name))))
+ (shr-generic dom)
+ ;; How to attach a property to nothing? Make an invisible
+ ;; something; insert a character with a 'display property value of
+ ;; "". Although not displayed to the user, the character exists in
+ ;; the buffer, therefore the choice of character matters. Don't
+ ;; use a space because shr might eliminate it. Don't use something
+ ;; that `thing-at-point' considers part of a symbol (in case user
+ ;; inovkes `racket-describe-search' with point here).
+ (when (= start (point))
+ (insert ?^)
+ (put-text-property (1- (point)) (point) 'display ""))
+ (put-text-property start (1+ start) 'racket-anchor id)))
+
+(defun racket-render-tag-racket-nav (dom)
+ (setq racket--describe-nav dom))
+
+(defun racket--describe-nav (which)
+ (interactive)
+ (let ((path (dom-attr racket--describe-nav which)))
+ (unless path
+ (user-error "There is no %s page available" which))
+ (setq racket--describe-stack-forward nil)
+ (racket--describe-maybe-push-here 'back)
+ (racket--describe-fetch-and-show path nil)))
+
+(defun racket-describe-nav-top ()
+ (interactive)
+ (racket--describe-nav 'top))
+
+(defun racket-describe-nav-up ()
+ (interactive)
+ (racket--describe-nav 'up))
+
+(defun racket-describe-nav-prev ()
+ (interactive)
+ (racket--describe-nav 'prev))
+
+(defun racket-describe-nav-next ()
+ (interactive)
+ (racket--describe-nav 'next))
+
+(defun racket--describe-fetch-and-show (path goto)
+ "Insert shr dom for PATH and move point to GOTO.
+
+PATH is doc path, as in the \"racket-doc-link-path\" button
+property.
+
+GOTO is as in `racket--describe-goto'."
+ (if (equal path (car racket--describe-here))
+ (racket--describe-goto goto) ;just move, same page
+ (setq header-line-format
+ (propertize
+ (format "Waiting for documentation file %s"
+ path)
+ 'face 'italic))
+ (condition-case e
+ (racket--describe-insert-dom path
+ goto
+ (racket--scribble-path->shr-dom path))
+ (error
+ (setq header-line-format
+ (propertize (format "%S" e)
+ 'face 'error))
+ (setq racket--describe-here nil)))))
+
+(defun racket--describe-maybe-push-here (which)
+ "When it is a path, push `racket--describe-here' to WHICH stack.
+
+It might not be a path when for instance the back end describe
+command does not find documentation."
+ (pcase racket--describe-here
+ (`(,(and path (pred stringp)) . ,_)
+ (let ((v (cons path (point))))
+ (pcase which
+ ('back (push v racket--describe-stack-back))
+ ('forward (push v racket--describe-stack-forward))
+ (_ (error "bad value for WHICH %s" which)))))))
+
+(defun racket-describe-doc-link-button (button)
+ "Action for racket-doc-link-button."
+ (let ((path (button-get button 'racket-doc-link-path))
+ (anchor (button-get button 'racket-doc-link-anchor)))
+ (when path
+ (racket--describe-maybe-push-here 'back)
+ (setq racket--describe-stack-forward nil)
+ (racket--describe-fetch-and-show path anchor))))
+
+(defun racket-describe-back ()
+ "Go back to the previous topic, like in a web browser."
+ (interactive)
+ (unless racket--describe-stack-back
+ (user-error "No backward history"))
+ (racket--describe-maybe-push-here 'forward)
+ (pcase-let ((`(,path . ,pos) (pop racket--describe-stack-back)))
+ (racket--describe-fetch-and-show path pos)))
+
+(defun racket-describe-forward ()
+ "Go forward to the topic from where `racket-describe-back' came."
+ (interactive)
+ (unless racket--describe-stack-forward
+ (user-error "No forward history"))
+ (racket--describe-maybe-push-here 'back)
+ (pcase-let ((`(,path . ,pos) (pop racket--describe-stack-forward)))
+ (racket--describe-fetch-and-show path pos)))
+
+(defun racket-describe-ext-link-button (button)
+ "Action for racket-ext-link-button."
+ (let ((href (button-get button 'racket-ext-link-href)))
+ (racket-browse-url href)))
+
+(defun racket-describe-mode-revert-buffer (_ignore-auto _noconfirm)
+ (when-let (page (car racket--describe-here))
+ (setq racket--describe-here nil)
+ (racket--describe-fetch-and-show page (point))))
+
+(defun racket-describe-browse-external ()
+ "Open the current page using the variable `racket-browse-url-function'.
+
+The anchor is the first one at or before point, if any."
+ (interactive)
+ (when-let (page (car racket--describe-here))
+ (if-let (anchor (or (get-text-property (point) 'racket-anchor)
+ (when-let (pos (previous-single-property-change
+ (point) 'racket-anchor))
+ (or (get-text-property pos 'racket-anchor)
+ (when (< (point-min) pos)
+ (get-text-property (1- pos) 'racket-anchor))))))
+ (racket-browse-url (concat page "#" (url-hexify-string anchor)))
+ (racket-browse-url page))))
(defvar racket-describe-mode-map
- (let ((m (make-sparse-keymap)))
- (set-keymap-parent m special-mode-map)
- (mapc (lambda (x)
- (define-key m (kbd (car x)) (cadr x)))
- '(("<tab>" racket-describe--next-button)
- ("S-<tab>" racket-describe--prev-button)))
- m)
+ (let ((map (racket--easy-keymap-define
+ `(("<tab>" ,#'forward-button)
+ ("<backtab>" ,#'backward-button)
+ (("l" "b" "C-c C-b") ,#'racket-describe-back)
+ (("r" "f" "C-c C-f") ,#'racket-describe-forward)
+ (("C-c C-s" "i") ,#'racket-describe-search)
+ ("n" ,#'racket-describe-nav-next)
+ ("p" ,#'racket-describe-nav-prev)
+ ("^" ,#'racket-describe-nav-up)
+ ("C-^" ,#'racket-describe-nav-top)
+ ("x" ,#'racket-describe-browse-external)))))
+ (define-key map [XF86Back] 'racket-describe-back)
+ (define-key map [XF86Forward] 'racket-describe-back)
+ (set-keymap-parent map special-mode-map)
+ map)
"Keymap for Racket Describe mode.")
(define-derived-mode racket-describe-mode special-mode
"RacketDescribe"
- "Major mode for describing Racket functions.
-\\{racket-describe-mode-map}"
- (setq show-trailing-whitespace nil))
+ "Major mode for viewing Racket documentation.
-(defun racket-describe--next-button ()
- (interactive)
- (forward-button 1 t t))
+Many of the default key bindings are similar to `Info-mode', such
+as:
-(defun racket-describe--prev-button ()
- (interactive)
- (forward-button -1 t t))
+- TAB and S-TAB to move among links.
+
+- RET to follow the link at point.
+
+- ^/n/p for up/next/prev page.
+
+- l/r for back/forward history.
+
+- i or C-c C-s to search the documentation index.
+
+Also notable:
+
+- C-^ to go to the very top documentation index page.
+
+- x to open the page using `racket-describe-browse-external'.
+
+Internal, intra-doc links -- which go to other doc pages in the
+same `racket-describe-mode' buffer in Emacs -- are given
+`racket-describe-doc-link-face' unless the documentation
+specifies some non-default face.
+
+External links -- which are opened using the variable
+`racket-browse-url-function', by default in an external web
+browser program -- are given `racket-describe-ext-link-face'.
+
+\\{racket-describe-mode-map}"
+ (setq show-trailing-whitespace nil)
+ (setq-local revert-buffer-function #'racket-describe-mode-revert-buffer)
+ (buffer-disable-undo))
;;; Search and disambiguation using local docs
@@ -127,20 +465,40 @@ Returns the buffer in which the description was written."
;; documentation, disambiguate in a buffer, and view in a
;; racket-describe-mode buffer.
-;; Note: If we merge the multi back ends branch, this will need to
-;; become a hash-table.
-(defvar racket--local-doc-index-names nil)
+(defvar racket--describe-terms (make-hash-table :test 'equal)
+ "Used for completion candidates.")
+
+(defun racket--remove-describe-terms ()
+ "A `racket-stop-back-end-hook' to clean up `racket--describe-terms'."
+ (let ((key (racket-back-end-name)))
+ (when key
+ (remhash key racket--describe-terms))))
-(defun racket--local-doc-index-names ()
- (unless racket--local-doc-index-names
- (with-temp-message "Reading local documentation index..."
- (setq racket--local-doc-index-names
- (racket--cmd/await nil `(doc-index-names)))))
- (unless racket--local-doc-index-names
- (error "Can't read documentation index"))
- racket--local-doc-index-names)
+(add-hook 'racket-stop-back-end-hook #'racket--remove-describe-terms)
-(defun racket-search-describe ()
+(defun racket--describe-terms ()
+ (let ((key (racket-back-end-name)))
+ (pcase (gethash key racket--describe-terms)
+ (`nil
+ (puthash key 'fetching
+ racket--describe-terms)
+ (racket--cmd/async nil
+ '(doc-index-names)
+ (lambda (names)
+ (puthash key
+ (sort names #'string-lessp)
+ racket--describe-terms)))
+ ;; Wait for response but if waiting too long just return nil,
+ ;; and use the response next time.
+ (with-temp-message "Getting completion candidates from back end..."
+ (with-timeout (5 nil)
+ (while (equal 'fetching (gethash key racket--describe-terms))
+ (accept-process-output nil 0.01))
+ (gethash key racket--describe-terms))))
+ ('fetching nil)
+ ((and (pred listp) names) names))))
+
+(defun racket-describe-search ()
"Search installed documentation; view using `racket-describe-mode'.
Always prompts you to enter a symbol, defaulting to the symbol at
@@ -155,50 +513,81 @@ point if any.
Racket Describe buffer for that module's version of the thing.
"
(interactive)
- (let ((key (racket--symbol-at-point-or-prompt t "Describe: "
- (racket--local-doc-index-names))))
- (pcase (racket--cmd/await nil `(doc-index-lookup ,key))
- (`() (message "not found"))
- (`((,_mods ,path ,anchor)) (racket-search-describe-visit key path anchor))
- (vs
- (with-current-buffer (get-buffer-create
- (format "*Racket Search Describe `%s`*" key))
- (let ((col-name (format "`%s` as provided by" key)))
- (racket-search-describe-mode)
- (setq tabulated-list-format (vector (list col-name 80 t)))
- (setq tabulated-list-entries
- (mapcar (pcase-lambda (`(,mods ,path ,anchor))
- (list nil
- (vector
- (list (string-join mods ", ")
- 'face 'default
- 'key key
- 'path path
- 'anchor anchor
- 'action #'racket-search-describe-button))))
- vs))
- (tabulated-list-init-header)
- (tabulated-list-print)
- (pop-to-buffer (current-buffer))))))))
-
-(defun racket-search-describe-button (button)
- (racket-search-describe-visit (button-get button 'key)
- (button-get button 'path)
- (button-get button 'anchor)))
-
-(defun racket-search-describe-visit (term path anchor)
- (racket--do-describe (cons path anchor)
- (racket--repl-session-id)
- term
- t))
-
-(defvar racket-search-describe-mode-map
- (let ((map (make-sparse-keymap)))
+ (let* ((name (racket--symbol-at-point-or-prompt t "Describe: "
+ (racket--describe-terms)))
+ (buf-name (format "*Racket Search Describe `%s` <%s>*"
+ name
+ (racket-back-end-name))))
+ (racket--cmd/async
+ nil
+ `(doc-index-lookup ,name)
+ (lambda (result)
+ (pcase result
+ (`()
+ (message "No documention found for %s" name))
+ (`((,_term ,_what ,_from ,path ,anchor))
+ (racket-describe-search-visit name
+ (racket-file-name-back-to-front path)
+ anchor))
+ (vs
+ (with-current-buffer
+ (get-buffer-create buf-name)
+ (racket-describe-search-mode)
+ (let ((max-term 0)
+ (max-what 0))
+ (setq tabulated-list-entries
+ (mapcar
+ (pcase-lambda (`(,term ,what ,from ,path ,anchor))
+ (let ((from (format "%s" from))
+ (what (pcase what
+ (`(,m . ,c) (concat (symbol-name m)
+ " of "
+ (symbol-name c)))
+ (`() "")
+ (_ (symbol-name what)))))
+ (setq max-term (max max-term (length term)))
+ (setq max-what (max max-what (length what)))
+ (list nil
+ (vector
+ (list term
+ 'name term
+ 'path (racket-file-name-back-to-front path)
+ 'anchor anchor
+ 'action #'racket-describe-search-button)
+ what
+ from))))
+ vs))
+ (setq tabulated-list-sort-key nil)
+ (setq tabulated-list-format
+ (vector (list "Name" (max max-term (length "Name ")) nil)
+ (list "Kind" (max max-what (length "Kind ")) t)
+ (list "From" 99 t)))
+ (setq tabulated-list-padding 0)
+ (tabulated-list-init-header)
+ (tabulated-list-print)
+ (pop-to-buffer (current-buffer))))))))))
+
+(defun racket-describe-search-button (button)
+ (racket-describe-search-visit
+ (button-get button 'name)
+ (button-get button 'path)
+ (button-get button 'anchor)))
+
+(defun racket-describe-search-visit (term path anchor)
+ (racket--do-describe
+ (cons path anchor)
+ nil
+ term))
+
+(defvar racket-describe-search-mode-map
+ (let ((map (racket--easy-keymap-define
+ '(("C-c C-s" racket-describe-search)))))
map))
-(define-derived-mode racket-search-describe-mode tabulated-list-mode
+(define-derived-mode racket-describe-search-mode tabulated-list-mode
"RacketSearchDescribe"
- "Major mode for disambiguating documentation search results.")
+ "Major mode for disambiguating documentation search results.
+\\{racket-describe-search-mode-map}")
(provide 'racket-describe)
diff --git a/racket-doc.el b/racket-doc.el
index 73b2106..0bd303f 100644
--- a/racket-doc.el
+++ b/racket-doc.el
@@ -6,22 +6,20 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+(require 'url-util)
(require 'racket-browse-url)
(require 'racket-cmd)
(require 'racket-custom)
(require 'racket-util)
+(require 'racket-back-end)
(declare-function racket--repl-session-id "racket-repl.el" ())
+(defun racket--doc-assert-local-back-end ()
+ (unless (racket--back-end-local-p)
+ (user-error "Cannot use web browser to browse remote documentation; instead use `racket-describe'")))
+
(defun racket--doc (prefix how completions)
"A helper for `racket-xp-documentation' and `racket-repl-documentation'."
(let ((search-p (equal prefix '(16))))
@@ -32,6 +30,7 @@
((and (pred stringp) str)
(if search-p
(racket--search-doc str)
+ (racket--doc-assert-local-back-end)
(racket--doc-command (when (eq how 'namespace)
(racket--repl-session-id))
how
@@ -41,20 +40,24 @@
"A helper for `racket--doc', `racket-xp-describe', and `racket-repl-describe'.
Centralizes how to issue doc command and handle response correctly."
- (racket--cmd/async repl-session-id
- `(doc ,how ,str)
- (lambda (maybe-url)
- (if maybe-url
- (racket-browse-url maybe-url)
- (racket--search-doc str)))))
+ (let ((how (racket-how-front-to-back how)))
+ (racket--cmd/async repl-session-id
+ `(doc ,how ,str)
+ (lambda (maybe-url)
+ (if maybe-url
+ (racket-browse-url maybe-url)
+ (racket--search-doc str))))))
(defun racket--search-doc (str)
"Search docs where the variable `racket-documentation-search-location' says."
(pcase racket-documentation-search-location
- ((and (pred stringp) url) (racket-browse-url (format url str)))
- ('local (racket--search-doc-locally str))))
+ ((and (pred stringp) url) (racket-browse-url (format url (url-hexify-string str))))
+ ('local (racket--search-doc-locally str))
+ (_ (user-error "Unknown value for `racket-documentation-search-location': %s"
+ racket-documentation-search-location))))
(defun racket--search-doc-locally (str)
+ (racket--doc-assert-local-back-end)
(call-process (expand-file-name racket-program)
nil ;INFILE: none
0 ;DESTINATION: discard/don't wait
diff --git a/racket-edit.el b/racket-edit.el
index 4af508c..6d8c4ce 100644
--- a/racket-edit.el
+++ b/racket-edit.el
@@ -6,22 +6,13 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;; racket-mode per se, i.e. the mode for .rkt file buffers
(require 'cl-lib)
(require 'cl-macs)
(require 'comint)
-(require 'ido)
(require 'racket-custom)
(require 'racket-cmd)
(require 'racket-common)
@@ -31,33 +22,6 @@
(require 'hideshow)
(require 'xref)
-(defun racket-racket ()
- "Do \"racket <file>\" in a shell buffer."
- (interactive)
- (racket--shell (concat (shell-quote-argument racket-program)
- " "
- (shell-quote-argument (racket--buffer-file-name)))))
-
-(defun racket-raco-test ()
- "Do \"raco test -x <file>\" in a shell buffer to run the \"test\" submodule."
- (interactive)
- (racket--shell (concat (shell-quote-argument racket-program)
- " -l raco test -x "
- (shell-quote-argument (racket--buffer-file-name)))))
-
-(defun racket--shell (cmd)
- (racket--save-if-changed)
- (let ((w (selected-window)))
- (pcase (get-buffer-window "*shell*" t)
- (`() (other-window -1))
- (win (select-window win)))
- (with-temp-message cmd
- (shell)
- (pop-to-buffer-same-window "*shell*")
- (comint-send-string "*shell*" (concat cmd "\n"))
- (select-window w)
- (sit-for 3))))
-
;;; code folding
;;;###autoload
@@ -239,9 +203,9 @@ typed/racket/base\"."
(defun racket--module-requires (what &optional outermost-p)
"Identify all require forms and do WHAT.
-When WHAT is 'find, return the require forms.
+When WHAT is \"find\", return the require forms.
-When WHAT is 'kill, kill the require forms and return the
+When WHAT is \"kill\", kill the require forms and return the
position where the first one had started.
OUTERMOST-P says which module's requires: true means the
@@ -290,7 +254,7 @@ module form, meaning the outermost, file module."
(and (eq ?\( (char-syntax (char-after)))
(save-excursion
(down-list 1)
- (looking-at "require"))))
+ (looking-at-p "require"))))
(defun racket-add-require-for-identifier ()
"Add a require for the identifier at point.
@@ -298,10 +262,7 @@ module form, meaning the outermost, file module."
When more than one module supplies an identifer with the same
name, they are listed for you to choose one. The list is sorted
alphabetically, except modules starting with \"racket/\" and
-\"typed/racket/\" are sorted before others. While at the prompt,
-as a convenience you can press C-h to see the \"Search Manuals\"
-page for locally installed packages -- effectively like
-doing \"raco doc\" at the command line.
+\"typed/racket/\" are sorted before others.
A \"require\" form is inserted into the buffer, followed by doing
a `racket-tidy-requires'.
@@ -329,17 +290,10 @@ identifiers that are exported but not documented."
(`(,lib)
lib)
(libs
- (let* ((map (prog1 (make-sparse-keymap)))
- (_ (set-keymap-parent map ido-completion-map))
- (_ (define-key map "\C-h"
- (lambda ()
- (interactive)
- (racket--search-doc-locally sym-at-point))))
- (overriding-local-map map))
- (ido-completing-read
- (format "\"%s\" is provided by multiple libraries, choose one (C-h to search manuals): "
- sym-at-point)
- libs))))))
+ (completing-read
+ (format "\"%s\" is provided by multiple libraries, choose one: "
+ sym-at-point)
+ libs)))))
(when lib
(let ((pt (copy-marker (point)))
(req `(require ,(intern lib))))
@@ -377,8 +331,8 @@ For example with point on the \"[\" before \"a\":
[bar 23]) [bar 23])
....) ....)
- '([a . 12] '([a . 12]
- [bar . 23]) [bar . 23])
+ ([a . 12] ([a . 12]
+ [bar . 23]) [bar . 23])
(cond [a? #t] (cond [a? #t]
[b? (f x [b? (f x
@@ -389,8 +343,8 @@ For example with point on the \"[\" before \"a\":
Or with point on the quote before \"a\":
#+BEGIN_SRC racket
- (list 'a 12 (list 'a 12
- 'bar 23) 'bar 23)
+ (list a 12 (list a 12
+ bar 23) bar 23)
#+END_SRC
If more than one couple is on the same line, none are aligned,
diff --git a/racket-eldoc.el b/racket-eldoc.el
index be70f92..a49537e 100644
--- a/racket-eldoc.el
+++ b/racket-eldoc.el
@@ -6,37 +6,31 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-cmd)
+(require 'racket-back-end)
(defun racket--do-eldoc (how repl-session-id)
(and (racket--cmd-open-p)
(> (point) (point-min))
(save-excursion
(condition-case nil
- ;; The char-before and looking-at checks below are to
+ ;; The char-before and looking-at-p checks below are to
;; skip when the sexp is quoted or when its first elem
;; couldn't be a Racket function name.
(let* ((beg (progn
(backward-up-list)
(and (not (memq (char-before) '(?` ?' ?,)))
(progn (forward-char 1) (point)))))
- (beg (and beg (looking-at "[^0-9#'`,\"]") beg))
+ (beg (and beg (looking-at-p "[^0-9#'`,\"]") beg))
(end (and beg (progn (forward-sexp) (point))))
(end (and end
(char-after (point))
(eq ?\s (char-syntax (char-after (point))))
end))
(sym (and beg end (buffer-substring-no-properties beg end)))
+ (how (racket-how-front-to-back how))
(str (and sym (racket--cmd/await repl-session-id
`(type ,how ,sym)))))
str)
diff --git a/racket-font-lock.el b/racket-font-lock.el
index 370d3a2..b978e05 100644
--- a/racket-font-lock.el
+++ b/racket-font-lock.el
@@ -1,28 +1,20 @@
;;; racket-font-lock.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2021 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
+(require 'color)
(require 'racket-custom)
(require 'racket-keywords-and-builtins)
(require 'racket-ppss)
(require 'racket-util)
-
-;; Define 3 levels of font-lock, as documented in 23.6.5 "Levels of
+;; Define 4 levels of font-lock, as documented in 23.6.5 "Levels of
;; Font Lock". User may control using `font-lock-maximum-decoration'.
;; Note: font-lock iterates by matcher, doing an re-search-forward
@@ -37,8 +29,7 @@
(defconst racket-font-lock-keywords-0
(eval-when-compile
- `(
- ;; #shebang
+ `(;; #shebang
(,(rx bol "#!" (+ nonl) eol) . font-lock-comment-face)
;; #lang
@@ -48,104 +39,163 @@
(2 font-lock-keyword-face nil t)
(3 font-lock-variable-name-face nil t))
- ;; #; sexp comments
- ;;
- ;; We don't put any comment syntax on these -- that way things
- ;; like indent and nav work within the sexp. They are solely
- ;; font-locked as comments, here.
- (,#'racket--font-lock-sexp-comments)
-
;; #<< here strings
;;
;; We only handle the opening #<<ID here. The remainder is
- ;; handled in `racket-font-lock-syntatic-face-function'.
- (,(rx (group "#<<" (+? (not (any blank ?\n)))) ?\n)
+ ;; handled in `racket-font-lock-syntactic-face-function'.
+ (,(rx (group "#<<" (+? (not (any ?\n)))) (group ?\n))
(1 racket-here-string-face nil t))
))
"Strings, comments, #lang.")
(defconst racket-font-lock-keywords-1
(eval-when-compile
- `(
- ;; keyword argument
+ `(;; Keyword arguments
(,(rx "#:" (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))
. racket-keyword-argument-face)
+ ;; Character literals
+ (,(rx (seq "#\\" (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
+ . font-lock-constant-face)
- ;; Various things for racket-selfeval-face
- (,(rx (or
- ;; symbol
- (seq ?' ?| (+ any) ?|)
- (seq ?' (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))
- (seq "#\\" (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))))
- . racket-selfeval-face)
-
- ;; #rx #px
+ ;; Regular expression literals
(,(rx (group (or "#rx" "#px")) ?\")
- 1 racket-selfeval-face)
-
- ;; Some self-eval constants
- (,(regexp-opt '("#t" "#true" "#f" "#false" "+inf.0" "-inf.0" "+nan.0") 'symbols)
- . racket-selfeval-face)
+ 1 font-lock-constant-face)
- ;; Numeric literals including Racket reader hash prefixes.
+ ;; Misc reader literals
+ (,(rx
+ symbol-start
+ (or "#t" "#T" "#true"
+ "#f" "#F" "#false"
+ (seq (any "-+")
+ (or (regexp "[iI][nN][fF]")
+ (regexp "[nN][aA][nN]"))
+ "." (any "0fFtT")))
+ symbol-end)
+ . font-lock-constant-face)
+
+ ;; Numeric literals
(,(rx
- (seq symbol-start
- (or
- ;; #d #e #i or no hash prefix
- (seq (? "#" (any "dei"))
- (? (any "-+"))
- (1+ digit)
- (? (any "./") (1+ digit))
- (? ?e
- (? (any "-+"))
- (1+ digit))
- (? ?+
- (1+ digit)
- (? (any "./") (1+ digit))
- (? ?e
- (? (any "-+"))
- (1+ digit))
- ?i))
- ;; #x
- (seq "#x"
- (? (any "-+"))
- (1+ hex-digit)
- (? (any "./") (1+ hex-digit)))
- ;; #b
- (seq "#b"
- (or (seq (? (any "-+"))
- (1+ (any "01"))
- (? (any "./") (1+ (any "01"))))
- (seq (1+ (any "01"))
- ?e
- (? (any "-+"))
- (1+ (any "01")))))
- ;; #o
- (seq "#o"
- (or (seq (? (any "-+"))
- (1+ (any "0-7"))
- (? (any "./") (1+ (any "0-7"))))
- (seq (1+ (any "0-7"))
- ?e
- (? (any "-+"))
- (1+ (any "0-7"))))))
- symbol-end))
- . racket-selfeval-face)
-
- ))
- "Self-evals")
+ symbol-start
+ (or
+ ;; #d #e #i or no hash prefix
+ (seq (? "#" (any "dDeEiI"))
+ (? (any "-+"))
+ (1+ digit)
+ (? (any "./") (1+ digit))
+ (? (any "eEfF")
+ (? (any "-+"))
+ (1+ digit))
+ (? (any "-+")
+ (1+ digit)
+ (? (any "./") (1+ digit))
+ (? (any "eEfF")
+ (? (any "-+"))
+ (1+ digit))
+ (any "iI")))
+ ;; #x
+ (seq "#" (any "xX")
+ (? (any "-+"))
+ (1+ hex-digit)
+ (? (any "./") (1+ hex-digit))
+ (? (any "-+")
+ (1+ hex-digit)
+ (? (any "./") (1+ hex-digit))
+ (any "iI")))
+ ;; #b
+ (seq "#" (any "bB")
+ (? (any "-+"))
+ (1+ (any "01"))
+ (? (any "./") (1+ (any "01")))
+ (? (any "eEfF")
+ (? (any "-+"))
+ (1+ (any "01")))
+ (? (any "-+")
+ (1+ (any "01"))
+ (? (any "./") (1+ (any "01")))
+ (? (any "eEfF")
+ (? (any "-+"))
+ (1+ (any "01")))
+ (any "iI")))
+ ;; #o
+ (seq "#" (any "oO")
+ (? (any "-+"))
+ (1+ (any "0-7"))
+ (? (any "./") (1+ (any "0-7")))
+ (? (any "eEfF")
+ (? (any "-+"))
+ (1+ (any "0-7")))
+ (? (any "-+")
+ (1+ (any "0-7"))
+ (? (any "./") (1+ (any "0-7")))
+ (? (any "eEfF")
+ (? (any "-+"))
+ (1+ (any "0-7")))
+ (any "iI")))
+ ;; extflonum
+ (or
+ ;; #d or no hash prefix
+ (seq (? "#" (any "dD"))
+ (? (any "-+"))
+ (1+ digit)
+ (? (any "./") (1+ digit))
+ (any "tT")
+ (? (any "-+"))
+ (1+ digit))
+ ;; #x
+ (seq "#" (any "xX")
+ (? (any "-+"))
+ (1+ hex-digit)
+ (? (any "./") (1+ hex-digit))
+ (any "tT")
+ (? (any "-+"))
+ (1+ hex-digit))
+ ;; #b
+ (seq "#" (any "bB")
+ (? (any "-+"))
+ (1+ (any "01"))
+ (? (any "./") (1+ (any "01")))
+ (any "tT")
+ (? (any "-+"))
+ (1+ (any "01")))
+ ;; #o
+ (seq "#" (any "oO")
+ (? (any "-+"))
+ (1+ (any "0-7"))
+ (? (any "./") (1+ (any "0-7")))
+ (any "tT")
+ (? (any "-+"))
+ (1+ (any "0-7")))))
+ symbol-end)
+ . font-lock-constant-face)
+
+ ;; (quasi)syntax reader shorthand for symbols only
+ (,(rx ?#
+ (or ?` ?')
+ (or
+ (seq ?| (+ any) ?|)
+ (seq (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))))
+ . racket-reader-syntax-quoted-symbol-face)
+
+ ;; (quasi)quote reader shorthand for symbols only
+ (,(rx (or ?` ?')
+ (or
+ (seq ?| (+ any) ?|)
+ (seq (1+ (or (syntax word) (syntax symbol) (syntax punctuation))))))
+ . racket-reader-quoted-symbol-face)))
+ "Symbols, constants, regular expressions")
(defconst racket-font-lock-keywords-2
(eval-when-compile
- `(
- ;; def* -- variables
+ `(;; def* -- variables
(,(rx (syntax open-parenthesis)
"def" (0+ (or (syntax word) (syntax symbol) (syntax punctuation)))
(1+ space)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
1 font-lock-variable-name-face)
(,(rx (syntax open-parenthesis)
- "define-values"
+ (or "define-syntaxes"
+ "define-values"
+ "define-values-for-syntax")
(1+ space)
(syntax open-parenthesis)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation) space)))
@@ -179,14 +229,12 @@
(1+ space)
(group (1+ (or (syntax word) (syntax symbol) (syntax punctuation)))))
(1 font-lock-keyword-face nil t)
- (2 font-lock-function-name-face nil t))
- ))
+ (2 font-lock-function-name-face nil t))))
"Parens, modules, function/variable identifiers, syntax-")
(defconst racket-font-lock-keywords-3
(eval-when-compile
- `(
- (,(regexp-opt racket-keywords 'symbols) . font-lock-keyword-face)
+ `((,(regexp-opt racket-keywords 'symbols) . font-lock-keyword-face)
(,(regexp-opt racket-builtins-1-of-2 'symbols) . font-lock-builtin-face)
(,(regexp-opt racket-builtins-2-of-2 'symbols) . font-lock-builtin-face)
(,(regexp-opt racket-type-list 'symbols) . font-lock-type-face)
@@ -202,37 +250,44 @@
(compose-region (match-beginning 1)
(match-end 1)
racket-lambda-char)))
- nil t)
- ))
+ nil t)))
"Function/variable identifiers, Typed Racket types.
Note: To the extent you use #lang racket or #typed/racket, this
may be handy. But Racket is also a tool to make #lang's, and this
doesn't really fit that.")
+(defconst racket-font-lock-keywords-sexp-comments
+ (eval-when-compile
+ `((,#'racket--font-lock-sexp-comments))))
+
(defconst racket-font-lock-keywords-level-0
- (append racket-font-lock-keywords-0))
+ (append racket-font-lock-keywords-0
+ racket-font-lock-keywords-sexp-comments))
(defconst racket-font-lock-keywords-level-1
(append racket-font-lock-keywords-0
- racket-font-lock-keywords-1))
+ racket-font-lock-keywords-1
+ racket-font-lock-keywords-sexp-comments))
(defconst racket-font-lock-keywords-level-2
(append racket-font-lock-keywords-0
racket-font-lock-keywords-1
- racket-font-lock-keywords-2))
+ racket-font-lock-keywords-2
+ racket-font-lock-keywords-sexp-comments))
(defconst racket-font-lock-keywords-level-3
(append racket-font-lock-keywords-0
racket-font-lock-keywords-1
racket-font-lock-keywords-2
- racket-font-lock-keywords-3))
+ racket-font-lock-keywords-3
+ racket-font-lock-keywords-sexp-comments))
(defconst racket-font-lock-keywords
- '(racket-font-lock-keywords-level-0
- racket-font-lock-keywords-level-1
- racket-font-lock-keywords-level-2
- racket-font-lock-keywords-level-3))
+ (list 'racket-font-lock-keywords-level-0
+ 'racket-font-lock-keywords-level-1
+ 'racket-font-lock-keywords-level-2
+ 'racket-font-lock-keywords-level-3))
(defun racket-font-lock-syntactic-face-function (state)
(let ((q (racket--ppss-string-p state)))
@@ -268,18 +323,18 @@ of example/example.rkt."
(goto-char (match-end 0))
(forward-comment (buffer-size))
(let ((num-prefixes 1))
- (while (looking-at (rx "#;"))
- (cl-incf num-prefixes)
- (racket--region-set-face (match-beginning 0) (match-end 0)
- 'font-lock-comment-delimiter-face t)
- (goto-char (match-end 0))
- (forward-comment (buffer-size)))
+ (save-match-data
+ (while (looking-at (rx "#;"))
+ (cl-incf num-prefixes)
+ (racket--region-set-face (match-beginning 0) (match-end 0)
+ 'font-lock-comment-delimiter-face t)
+ (goto-char (match-end 0))
+ (forward-comment (buffer-size))))
;; Font-lock as many successive sexprs as prefixes
(dotimes (_ num-prefixes)
(let ((beg (point)))
(forward-sexp 1)
- (racket--region-set-face beg (point)
- 'font-lock-comment-face t)
+ (racket--region-transform-faces beg (point) #'racket--sexp-comment-face)
(forward-comment (buffer-size)))))
;; Cover everything from the beginning of the first prefix to
;; the end of the last sexp with font-lock-multiline; #443.
@@ -320,9 +375,9 @@ similar, it will already be there."
;; check rhs of bindings for more lets.
(save-excursion
;; Check for named let
- (when (looking-at (rx (+ space) (+ (or (syntax word)
- (syntax symbol)
- (syntax punctuation)))))
+ (when (looking-at-p (rx (+ space) (+ (or (syntax word)
+ (syntax symbol)
+ (syntax punctuation)))))
(forward-sexp 1)
(backward-sexp 1)
(racket--sexp-set-face font-lock-function-name-face))
@@ -334,7 +389,7 @@ similar, it will already be there."
(down-list 1) ;to the open paren of the first binding form
(while (ignore-errors
(down-list 1) ;to the id or list of id's
- (if (not (looking-at "[([{]"))
+ (if (not (looking-at-p "[([{]"))
(racket--sexp-set-face font-lock-variable-name-face)
;; list of ids, e.g. let-values
(down-list 1) ;to first id
@@ -356,7 +411,7 @@ similar, it will already be there."
(error nil)))
(defun racket--sexp-set-face (face &optional forcep)
- "Set 'face prop to FACE, rear-nonsticky, for the sexp starting at point.
+ "Set \"face\" prop to FACE, rear-nonsticky, for the sexp starting at point.
Unless FORCEP is t, does so only if not already set in the
region.
@@ -367,7 +422,7 @@ Moves point to the end of the sexp."
forcep))
(defun racket--region-set-face (beg end face &optional forcep)
- "Set 'face prop to FACE, rear-nonsticky, in the region BEG..END.
+ "Set \"face\" prop to FACE, rear-nonsticky, in the region BEG..END.
Unless FORCEP is t, does so only if not already set in the
region."
(when (or forcep (not (text-property-not-all beg end 'face nil)))
@@ -376,6 +431,120 @@ region."
;;rear-nonsticky (face)
))))
+(defun racket--region-transform-faces (beg end func)
+ (let ((i nil)) ;make byte-compiler happy
+ (cl-loop for i being the intervals from beg to end
+ do
+ (racket--region-set-face (car i) (cdr i)
+ (funcall func
+ (or (get-text-property (car i) 'face)
+ 'default))
+ 'force))))
+
+;;; s-expression comment fades
+
+;; Challenges: Emacs doesn't have a face property for alpha
+;; transparency, or even a technique to apply a procedural transform
+;; to an existing face. Furthermore, the user could customize faces
+;; including loading an entire new theme at any time.
+;;
+;; Therefore our approach below:
+;;
+;; The function `racket--sexp-comment-face', given some existing face,
+;; returns the name of a "faded" equivalent face (creating that face
+;; if necessary). The list of non-faded faces for which we've created
+;; faded alternatives, so far, is in the variable
+;; `racket--sexp-commented-faces'. The command
+;; `racket-refresh-sexp-comment-faces' uses that list to update the
+;; specs for the faded faces; it is called automatically after
+;; `load-theme' and after customizing (via the UI) the variable
+;; `racket-sexp-comment-fade'. In other situations the user may need
+;; to run or call `racket-refresh-sexp-comment-faces' manually.
+
+(defvar racket--sexp-commented-faces nil
+ "The list of faces for which we've created faded equivalents.")
+
+(defun racket-refresh-sexp-comment-faces ()
+ "Refresh all alternative \"faded\" faces automatically created so far.
+
+Faces refresh automatically after `load-theme' and after
+customizing the variable `racket-sexp-comment-fade'.
+
+However if you customize a face used in a s-expression comment
+body -- as just one example, the face `font-lock-string-face' --
+you may need to run this command manually to make the faded
+equivalent match."
+ (interactive)
+ (mapc #'racket--sexp-comment-face-spec-set
+ racket--sexp-commented-faces))
+
+(defun racket-sexp-comment-fade-set (sym val)
+ "A target for the :set prop of the variable `racket-sexp-comment-fade'."
+ (unless (and (floatp val) (and (<= 0.0 val) (<= val 1.0)))
+ (user-error "Fade amount must be a float from 0.0 to 1.0 inclusive"))
+ (set sym val)
+ (racket-refresh-sexp-comment-faces))
+
+(defcustom racket-sexp-comment-fade 0.5
+ "How much to fade faces used in s-expression comment bodies.
+
+A number from 0.0 to 1.0, where 0.0 is 0% fade and 1.0 is 100%
+fade (invisible).
+
+This feature works by creating faces that are alternatives for
+faces used in s-expression comments. The alernative faces use a
+faded foreground color. The colors are recalculated automatically
+after you change the value of this customization variable and
+after any `load-theme'. However in other circumstances you might
+need to use `racket-refresh-sexp-comment-faces'."
+ :tag "Racket Sexp Comment Fade"
+ :type 'float
+ :safe t
+ :set #'racket-sexp-comment-fade-set
+ :group 'racket-other)
+
+(defun racket--sexp-comment-face-name (face)
+ (unless (facep face) (error "Not a face name: %s" face))
+ (intern (format "racket--sexp-comment--%s" face)))
+
+(defun racket--sexp-comment-face (face)
+ "Given a `facep' return a possibly different `facep' to use instead."
+ (if (facep face)
+ (let ((sexp-face (racket--sexp-comment-face-name face)))
+ (unless (facep sexp-face) ;create if we haven't yet
+ (racket--sexp-comment-face-spec-set face)
+ (push face racket--sexp-commented-faces))
+ sexp-face)
+ 'font-lock-comment-face))
+
+(defun racket--sexp-comment-face-spec-set (face)
+ "Create or refresh a faded variant of FACE."
+ (let* ((fg (if noninteractive "black" (face-foreground face nil 'default)))
+ (bg (if noninteractive "white" (face-background face nil 'default)))
+ (fg-rgb (color-name-to-rgb fg))
+ (bg-rgb (color-name-to-rgb bg))
+ (pct (- 1.0 (color-clamp (or racket-sexp-comment-fade 1.0))))
+ (faded-rgb (cl-mapcar (lambda (fg bg)
+ (color-clamp
+ (+ (* fg pct)
+ (* bg (- 1.0 pct)))))
+ fg-rgb bg-rgb))
+ (faded (apply #'color-rgb-to-hex faded-rgb))
+ (other-props (apply #'append
+ (mapcar (pcase-lambda (`(,k . ,v))
+ (unless (or (eq k :foreground)
+ (eq k :inherit)
+ (eq v 'unspecified))
+ (list k v)))
+ (face-all-attributes face))))
+ (spec `((t (:foreground ,faded ,@other-props))))
+ (doc (format "A faded variant of the face `%s'.\nSee the customization variable `racket-sexp-comment-fade'." face))
+ (faded-face-name (racket--sexp-comment-face-name face)))
+ (face-spec-set faded-face-name spec)
+ (set-face-documentation faded-face-name doc)))
+
+(define-advice load-theme (:after (&rest _args) racket-mode)
+ (racket-refresh-sexp-comment-faces))
(provide 'racket-font-lock)
diff --git a/racket-imenu.el b/racket-imenu.el
index 2032e77..a48add5 100644
--- a/racket-imenu.el
+++ b/racket-imenu.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
(require 'imenu)
@@ -39,29 +31,30 @@ and call us recursively."
"Return the identifier for the sexp at point if any, else nil.
If sexp at point is a Racket module form create a submenu."
- (cond ((looking-at (rx "(define" (* (or (syntax word)
- (syntax symbol)
- (syntax punctuation)))
- (+ (syntax whitespace))
- (* ?\()
- (group (+ (or (syntax word)
- (syntax symbol)
- (syntax punctuation))))))
- (list (cons (match-string-no-properties 1)
- (if imenu-use-markers
- (copy-marker (match-beginning 1))
- (match-beginning 1)))))
- ((looking-at (rx "(module" (? (any ?+ ?*))
- (+ (syntax whitespace))
- (group (+ (or (syntax word)
- (syntax symbol)
- (syntax punctuation))))))
- (save-excursion
- (goto-char (match-end 1))
- (racket--imenu-goto-start-of-current-sexp)
- (list (cons (concat "Module: " (match-string-no-properties 1))
- (racket--imenu-walk )))))
- (t nil)))
+ (save-match-data
+ (cond ((looking-at (rx "(define" (* (or (syntax word)
+ (syntax symbol)
+ (syntax punctuation)))
+ (+ (syntax whitespace))
+ (* ?\()
+ (group (+ (or (syntax word)
+ (syntax symbol)
+ (syntax punctuation))))))
+ (list (cons (match-string-no-properties 1)
+ (if imenu-use-markers
+ (copy-marker (match-beginning 1))
+ (match-beginning 1)))))
+ ((looking-at (rx "(module" (? (any ?+ ?*))
+ (+ (syntax whitespace))
+ (group (+ (or (syntax word)
+ (syntax symbol)
+ (syntax punctuation))))))
+ (save-excursion
+ (goto-char (match-end 1))
+ (racket--imenu-goto-start-of-current-sexp)
+ (list (cons (concat "Module: " (match-string-no-properties 1))
+ (racket--imenu-walk )))))
+ (t nil))))
(defun racket--imenu-goto-start-of-current-sexp ()
(ignore-errors
diff --git a/racket-indent.el b/racket-indent.el
index f10008f..077a43d 100644
--- a/racket-indent.el
+++ b/racket-indent.el
@@ -1,22 +1,15 @@
;;; racket-indent.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2021 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
+(require 'subr-x)
(require 'racket-util)
(require 'racket-custom)
(require 'racket-ppss)
@@ -53,46 +46,40 @@
"When `racket--mode-edits-racket-p' instead use `prog-indent-sexp'."
(apply (if (racket--mode-edits-racket-p) #'prog-indent-sexp orig)
args))
-(when (fboundp 'advice-add)
- (advice-add 'lisp-indent-line :around #'racket--lisp-indent-line-advice)
- (advice-add 'indent-sexp :around #'racket--indent-sexp-advice))
+(advice-add 'lisp-indent-line :around #'racket--lisp-indent-line-advice)
+(advice-add 'indent-sexp :around #'racket--indent-sexp-advice)
(defun racket-indent-line (&optional _whole-exp)
"Indent current line as Racket code.
-Normally you don't need to use this command directly, it is used
+Normally you don't invoke this command directly. Instead, because
+it is used as the value for the variable `indent-line-function'
+in `racket-mode' and `racket-repl-mode' buffers, it is used
automatically when you press keys like RET or TAB. However you
might refer to it when configuring custom indentation, explained
below.
-This behaves like `lisp-indent-line', except that whole-line
-comments are treated the same regardless of whether they start
-with single or double semicolons.
-
-- Automatically indents forms that start with \"begin\" in the
- usual way that \"begin\" is indented.
-
-- Automatically indents forms that start with \"def\" or
- \"with-\" in the usual way that \"define\" is indented.
-
-- Has rules for many specific standard Racket forms.
+Following the tradition of `lisp-mode' and `scheme-mode', the
+primary way to determine the indentation of a form is to look for
+a rule stored as a `racket-indent-function' property.
To extend, use your Emacs init file to
-#+BEGIN_SRC racket
- (put SYMBOL 'racket-indent-function INDENT)
+#+BEGIN_SRC emacs-lisp
+ (put SYMBOL \\='racket-indent-function INDENT)
#+END_SRC
-SYMBOL is the name of the Racket form like \"'test-case\" and
-INDENT is an integer or the symbol \"'defun\". When INDENT is an
+SYMBOL is the name of the Racket form like \"test-case\" and
+INDENT is an integer or the symbol \"defun\". When INDENT is an
integer, the meaning is the same as for lisp-indent-function and
scheme-indent-function: Indent the first INDENT arguments
-specially and indent any further arguments like a body.
+specially and indent any further arguments like a body. (The
+number may be negative; see discussion below.)
For example:
-#+BEGIN_SRC racket
- (put 'test-case 'racket-indent-function 1)
+#+BEGIN_SRC emacs-lisp
+ (put \\='test-case \\='racket-indent-function 1)
#+END_SRC
This will change the indent of `test-case` from this:
@@ -111,26 +98,91 @@ to this:
blah)
#+END_SRC
-If `racket-indent-function' has no property for a symbol,
-scheme-indent-function is also considered, although the \"with-\"
-indents defined by scheme-mode are ignored. This is only to help
-people who may have extensive scheme-indent-function settings,
-particularly in the form of file or dir local variables.
-Otherwise prefer putting properties on `racket-indent-function'."
+For backward compatibility, if `racket-indent-function' has no
+property for a symbol, a scheme-indent-function property is also
+considered, although the \"with-\" indents defined by scheme-mode
+are ignored. This is only to help people who may have extensive
+scheme-indent-function settings, particularly in the form of file
+or dir local variables. Otherwise prefer putting properties on
+`racket-indent-function'.
+
+If no explicit rules match, regular expressions are used for a
+couple special cases:
+
+- Forms that start with \"begin\" indent like \"begin\".
+
+- Forms that start with \"def\" or \"with-\" indent like
+ \"define\".
+
+On the one hand this is convenient when you create your own
+\"DRY\" macros; they will indent as expected without you needing
+to make custom indent rules. On the other hand there can be false
+matches; for example a function or form named \"defer\" will
+indent like \"define\". This is a known drawback and is unlikely
+to be fixed unless/until Racket macros someday support a protocol
+to communicate how they should be indented.
+
+There is also automatic handling for:
+
+- Forms that begin with a #:keyword (as found in contracts)
+
+- Literal forms like #hasheq()
+
+- Quoted forms when the variable `racket-indent-sequence-depth'
+ is > 0.
+
+- {} forms when the variable `racket-indent-curly-as-sequence' is
+ not nil.
+
+Finally and otherwise, a form will be indented as if it were a
+procedure application.
+
+--- --- ---
+
+Note: Racket Mode extends the traditional Emacs lisp indent spec
+to allow a /negative/ integer, which means that all distinguished
+forms should align with the first one. This style originated with
+\"for/fold\", which has two distinguished forms. Traditionally
+those would indent like this:
+
+#+BEGIN_SRC racket
+ (for/fold ([x xs])
+ ([y ys]) ; twice body indent
+ body)
+#+END_SRC
+
+However the popularly desired indent is:
+
+#+BEGIN_SRC racket
+ (for/fold ([x xs])
+ ([y ys]) ; same as first distingushed form
+ body)
+#+END_SRC
+
+This idea extends to optional distinguished forms, such as Typed
+Racket annotation \"prefixes\" in \"for/fold\", \"for/x\", and
+even \"let\" forms:
+
+#+BEGIN_SRC racket
+ (for/fold : Type
+ ([x xs])
+ ([y ys]) ; same as first distingushed form
+ body)
+#+END_SRC
+"
(interactive)
- (pcase (racket--calculate-indent)
- (`() nil)
+ (when-let (amount (racket--calculate-indent))
;; When point is within the leading whitespace, move it past the
;; new indentation whitespace. Otherwise preserve its position
;; relative to the original text.
- (amount (let ((pos (- (point-max) (point)))
- (beg (progn (beginning-of-line) (point))))
- (skip-chars-forward " \t")
- (unless (= amount (current-column))
- (delete-region beg (point))
- (indent-to amount))
- (when (< (point) (- (point-max) pos))
- (goto-char (- (point-max) pos)))))))
+ (let ((pos (- (point-max) (point)))
+ (beg (progn (beginning-of-line) (point))))
+ (skip-chars-forward " \t")
+ (unless (= amount (current-column))
+ (delete-region beg (point))
+ (indent-to amount))
+ (when (< (point) (- (point-max) pos))
+ (goto-char (- (point-max) pos))))))
(defun racket--calculate-indent ()
"Return appropriate indentation for current line as Lisp code.
@@ -145,7 +197,8 @@ need."
(beginning-of-line)
(let ((indent-point (point))
(state nil))
- (racket--plain-beginning-of-defun)
+ (racket--escape-string-or-comment)
+ (condition-case nil (backward-up-list 1) (scan-error nil))
(while (< (point) indent-point)
(setq state (parse-partial-sexp (point) indent-point 0)))
(let ((strp (racket--ppss-string-p state))
@@ -157,18 +210,6 @@ need."
(cont (goto-char (1+ cont)) (current-column))
(t (current-column)))))))
-(defun racket--plain-beginning-of-defun ()
- "Like default/plain `beginning-of-function'.
-Our `racket--beginning-of-defun-function' is aware of module
-forms and tailored to using C-M-a to navigate interactively. But
-it is too slow to be used here -- especially in \"degenerate\"
-cases like a 3000 line file consisting of one big `module` or
-`library` sexpr."
- (when (re-search-backward (rx bol (syntax open-parenthesis))
- nil
- 'move)
- (goto-char (1- (match-end 0)))))
-
(defun racket-indent-function (indent-point state)
"Called by `racket--calculate-indent' to get indent column.
@@ -198,11 +239,11 @@ the `racket-indent-function` property."
(racket--indent-defun indent-point body-indent))
(method
(funcall method indent-point state))
- ((string-match (rx bos (or "def" "with-")) head)
+ ((string-match-p (rx bos (or "def" "with-")) head)
(racket--indent-defun indent-point body-indent)) ;like 'defun
- ((string-match (rx bos "begin") head)
+ ((string-match-p (rx bos "begin") head)
(racket--indent-special-form 0 indent-point state))
- ((string-match (rx bos (or "for/" "for*/")) head)
+ ((string-match-p (rx bos (or "for/" "for*/")) head)
(racket--indent-for indent-point state))
(t
(racket--normal-indent indent-point state)))))))
@@ -215,7 +256,7 @@ the `racket-indent-function` property."
;; after list of formal parameters. (Although the following test
;; matches ":" elsewhere, the start of the previous list sexp is
;; the same as body-indent -- what we'd do anyway.)
- (or (and (looking-at "[ ]*:")
+ (or (and (looking-at-p "[ ]*:")
(ignore-errors
(backward-sexp 1)
(and (eq ?\( (char-syntax (char-after)))
@@ -226,21 +267,21 @@ the `racket-indent-function` property."
"Looking at things like #fl() #hash() or #:keyword ?
The last occurs in Racket contract forms, e.g. (->* () (#:kw kw)).
Returns nil for #% identifiers like #%app."
- (looking-at (rx ?\# (or ?\:
- (not (any ?\%))))))
+ (looking-at-p (rx ?\# (or ?\:
+ (not (any ?\%))))))
(defun racket--all-hyphens-p ()
"Magic for redex like what DrRacket does."
- (looking-at (rx (>= 3 ?-) (and (not (syntax word))
- (not (syntax symbol))
- (not (syntax punctuation))))))
+ (looking-at-p (rx (>= 3 ?-) (and (not (syntax word))
+ (not (syntax symbol))
+ (not (syntax punctuation))))))
(defun racket--data-sequence-p ()
"Looking at \"data\" sequences where we align under head item?
-These sequences include '() `() #() -- and {} when
-`racket-indent-curly-as-sequence' is t -- but never #'() #`() ,()
-,@().
+These sequences include \\='() \\=`() #() -- and {} when
+`racket-indent-curly-as-sequence' is t -- but never #\\='()
+#\\=`() ,() ,@().
To handle nested items, we search `backward-up-list' up to
`racket-indent-sequence-depth' times."
@@ -282,9 +323,9 @@ To handle nested items, we search `backward-up-list' up to
(if (ignore-errors
;; `backward-sexp' until we reach the start of a sexp that is the
;; first of its line (the start of the enclosing sexp).
- (while (string-match (rx (not blank))
- (buffer-substring (line-beginning-position)
- (point)))
+ (while (string-match-p (rx (not blank))
+ (buffer-substring (line-beginning-position)
+ (point)))
(setq last-sexp (prog1 (point)
(forward-sexp -1))))
t)
@@ -301,92 +342,92 @@ To handle nested items, we search `backward-up-list' up to
(current-column))))
(defun racket--indent-special-form (method indent-point state)
- "METHOD must be a nonnegative integer -- the number of
- \"special\" args that get extra indent when not on the first
- line. Any additinonl args get normal indent."
- ;; Credit: Substantially borrowed from clojure-mode
- (let ((containing-column (save-excursion
+ "Indent a special form starting with METHOD distinguished forms.
+
+METHOD must be an integer, the absolute value of which is the
+number of distinguished forms. When a distinguished form is on
+its own line (not on the first line) it gets special indent:
+
+- When METHOD is positive: Twice `lisp-body-indent',
+ which is the \"classic\" lisp behavior.
+
+- When METHOD is negative: Same as first distinguished form.
+
+Any additional, non-distinguished forms get normal indent."
+ ;; Credit: Substantially borrowed from clojure-mode --- although the
+ ;; concept of the "negative" number of distinguished forms is ours,
+ ;; introduced to handle some Racket forms like for/fold and the
+ ;; optional annotations of Typed Racket's let.
+ (let ((distinguished (abs method))
+ (containing-column (save-excursion
(goto-char (racket--ppss-containing-sexp state))
(current-column)))
- (pos -1))
+ (first-form-column (save-excursion
+ (skip-chars-forward " \t\n")
+ (current-column)))
+ (count -1))
(condition-case nil
(while (and (<= (point) indent-point)
(not (eobp)))
(forward-sexp 1)
- (cl-incf pos))
+ (cl-incf count))
;; If indent-point is _after_ the last sexp in the current sexp,
;; we detect that by catching the `scan-error'. In that case, we
;; should return the indentation as if there were an extra sexp
;; at point.
- (scan-error (cl-incf pos)))
- (cond ((= method pos) ;first non-distinguished arg
+ (scan-error (cl-incf count)))
+ (cond ((= distinguished count) ;first non-distinguished form
(+ containing-column lisp-body-indent))
- ((< method pos) ;more non-distinguished args
+ ((< distinguished count) ;other non-distinguished form
(racket--normal-indent indent-point state))
- (t ;distinguished args
- (+ containing-column (* 2 lisp-body-indent))))))
-
-(defun racket--conditional-indent (indent-point state looking-at-regexp true false)
+ (t ;distinguished form
+ (if (<= 0 method)
+ (+ containing-column (* 2 lisp-body-indent))
+ (if (zerop count) ;this _is_ the first form
+ (+ containing-column (* 2 lisp-body-indent))
+ first-form-column))))))
+
+(defun racket--indent-let (indent-point state)
+ "Indent a let form.
+
+We handle plain and named let, as well as the grammar for Typed
+Racket let."
(skip-chars-forward " \t")
- (let ((n (if (looking-at looking-at-regexp) true false)))
- (racket--indent-special-form n indent-point state)))
-
-(defconst racket--identifier-regexp
- (rx (or (syntax symbol) (syntax word) (syntax punctuation)))
- "A regexp matching valid Racket identifiers.")
-
-(defun racket--indent-maybe-named-let (indent-point state)
- "Indent a let form, handling named let (let <id> <bindings> <expr> ...)"
- (racket--conditional-indent indent-point state
- racket--identifier-regexp
- 2 1))
+ (let ((distinguished-forms
+ (if (looking-at-p (rx (or "#:forall" "#:∀") (any " \t")))
+ -3
+ (if (looking-at-p (rx (syntax open-parenthesis)))
+ 1
+ (save-excursion
+ (forward-sexp 1)
+ (skip-chars-forward " \t\n")
+ (if (looking-at-p (rx ?: (any " \t")))
+ -4
+ 2))))))
+ (racket--indent-special-form distinguished-forms
+ indent-point
+ state)))
(defun racket--indent-for (indent-point state)
- "Indent function for all for/ and for*/ forms EXCEPT
-for/fold and for*/fold.
+ "All for/ and for*/ forms except for/fold and for*/fold.
Checks for either of:
- maybe-type-ann e.g. (for/list : T ([x xs]) x)
- for/vector optional length, (for/vector #:length ([x xs]) x)"
- (racket--conditional-indent indent-point state
- (rx (or ?\: ?\#))
- 3 1))
+ (skip-chars-forward " \t\n")
+ (racket--indent-special-form (if (looking-at-p (rx (or ?\: ?\#))) -3 -1)
+ indent-point
+ state))
(defun racket--indent-for/fold (indent-point state)
- "Indent function for for/fold and for*/fold."
+ "Indent function for for/fold and for*/fold.
+
+Checks for maybe-type-ann e.g. (for/fold : T ([x xs]) ([y ys]) x) "
;; check for maybe-type-ann e.g. (for/fold : T ([n 0]) ([x xs]) x)
(skip-chars-forward " \t\n")
- (if (looking-at ":")
- (racket--indent-special-form 4 indent-point state)
- (racket--indent-for/fold-untyped indent-point state)))
-
-(defun racket--indent-for/fold-untyped (indent-point state)
- (let* ((containing-sexp-start (racket--ppss-containing-sexp state))
- (_ (goto-char containing-sexp-start))
- (containing-sexp-column (current-column))
- (containing-sexp-line (line-number-at-pos))
- (body-indent (+ containing-sexp-column lisp-body-indent))
- (clause-indent nil))
- ;; Move to the open paren of the first, accumulator sexp
- (forward-char 1) ;past the open paren
- (forward-sexp 2) ;to the next sexp, past its close paren
- (backward-sexp 1) ;back to its open paren
- ;; If the first, accumulator sexp is not on the same line as
- ;; `for/fold`, then this is simply specform 2.
- (if (/= (line-number-at-pos) containing-sexp-line) ;expensive?
- (racket--indent-special-form 2 indent-point state)
- (setq clause-indent (current-column))
- (forward-sexp 1) ;past close paren
- ;; Now go back to the beginning of the line holding
- ;; the indentation point. Count the sexps on the way.
- (parse-partial-sexp (point) indent-point 1 t)
- (let ((n 1))
- (while (and (< (point) indent-point)
- (ignore-errors
- (cl-incf n)
- (forward-sexp 1)
- (parse-partial-sexp (point) indent-point 1 t))))
- (if (= 1 n) clause-indent body-indent)))))
+ (racket--indent-special-form (if (looking-at-p (rx ?\:)) -4 -2)
+ indent-point
+ state))
(defun racket--get-indent-function-method (head)
"Get property of racket- or scheme-indent-function.
@@ -409,133 +450,141 @@ ignore a short list defined by scheme-mode itself."
with-values)))
(get sym 'scheme-indent-function)))))
-(defconst racket--indent-specs
- '(;; begin* forms default to 0 unless otherwise specified here
- (begin0 1)
- (c-declare 0)
- (c-lambda 2)
- (call-with-input-file defun)
- (call-with-input-file* defun)
- (call-with-output-file defun)
- (call-with-output-file* defun)
- (case 1)
- (case-lambda 0)
- (catch 1)
- (class defun)
- (class* defun)
- (compound-unit/sig 0)
- (cond 0)
- ;; def* forms default to 'defun unless otherwise specified here
- (delay 0)
- (do 2)
- (dynamic-wind 0)
- (fn 1) ;alias for lambda (although not officially in Racket)
- ;; for/ and for*/ forms default to racket--indent-for unless
- ;; otherwise specified here
- (for 1)
- (for/list racket--indent-for)
- (for/lists racket--indent-for/fold)
- (for/fold racket--indent-for/fold)
- (for* 1)
- (for*/lists racket--indent-for/fold)
- (for*/fold racket--indent-for/fold)
- (instantiate 2)
- (interface 1)
- (λ defun)
- (lambda defun)
- (lambda/kw defun)
- (let racket--indent-maybe-named-let)
- (let* 1)
- (letrec 1)
- (letrec-values 1)
- (let-values 1)
- (let*-values 1)
- (let+ 1)
- (let-syntax 1)
- (let-syntaxes 1)
- (letrec-syntax 1)
- (letrec-syntaxes 1)
- (letrec-syntaxes+values racket--indent-for/fold-untyped)
- (local 1)
- (let/cc 1)
- (let/ec 1)
- (match 1)
- (match* 1)
- (match-define defun)
- (match-lambda 0)
- (match-lambda* 0)
- (match-let 1)
- (match-let* 1)
- (match-let*-values 1)
- (match-let-values 1)
- (match-letrec 1)
- (match-letrec-values 1)
- (match/values 1)
- (mixin 2)
- (module 2)
- (module+ 1)
- (module* 2)
- (opt-lambda 1)
- (parameterize 1)
- (parameterize-break 1)
- (parameterize* 1)
- (place 1)
- (place/context 1)
- (quasisyntax/loc 1)
- (receive 2)
- (require/typed 1)
- (require/typed/provide 1)
- (send* 1)
- (shared 1)
- (sigaction 1)
- (splicing-let 1)
- (splicing-letrec 1)
- (splicing-let-values 1)
- (splicing-letrec-values 1)
- (splicing-let-syntax 1)
- (splicing-letrec-syntax 1)
- (splicing-let-syntaxes 1)
- (splicing-letrec-syntaxes 1)
- (splicing-letrec-syntaxes+values racket--indent-for/fold-untyped)
- (splicing-local 1)
- (splicing-syntax-parameterize 1)
- (struct defun)
- (syntax-case 2)
- (syntax-case* 3)
- (syntax-rules 1)
- (syntax-id-rules 1)
- (syntax-parse 1)
- (syntax-parser 0)
- (syntax-parameterize 1)
- (syntax/loc 1)
- (syntax-parse 1)
- (test-begin 0)
- (test-case 1)
- (unit defun)
- (unit/sig 2)
- (unless 1)
- (when 1)
- (while 1)
- ;; with- forms default to 1 unless otherwise specified here
- ))
-
-(defun racket--set-indentation ()
- "Set indentation for various Racket forms.
-
-Note that `racket-indent-function' handles some forms -- e.g.
-`begin*`, `def*` `for/*`, `with-*` -- with regexp matches for
-anything not explicitly listed here.
-
-Note that indentation is set for the symbol as listed, and also
-with a : suffix for legacy Typed Racket -- for example both `let`
-and `let:`. Although overzealous in the sense that Typed Racket
-doesn't define its own variant of all of these, these extras are
-harmless."
- (dolist (spec racket--indent-specs)
- (pcase-let* ((`(,plain-sym ,val) spec)
- (typed-sym (intern (format "%s:" plain-sym))))
- (put plain-sym 'racket-indent-function val)
- (put typed-sym 'racket-indent-function val))))
+;; Set 'racket-indent-line property value on symbols corresponding to
+;; various Racket syntax.
+;;
+;; Note that `racket-indent-function' handles some forms -- e.g.
+;; `begin*`, `def*` `for*`, `with-*` -- with regexp matches for
+;; anything not explicitly listed here.
+(dolist (spec
+ '(;; begin* forms default to 0 unless otherwise specified here
+ (begin0 1)
+ (c-declare 0)
+ (c-lambda 2)
+ (call-with-input-file defun)
+ (call-with-input-file* defun)
+ (call-with-output-file defun)
+ (call-with-output-file* defun)
+ (case 1)
+ (case-lambda 0)
+ (catch 1)
+ (class defun)
+ (class* defun)
+ (compound-unit/sig 0)
+ (cond 0)
+ ;; def* forms default to 'defun unless otherwise specified here
+ (delay 0)
+ (do 2)
+ (dynamic-wind 0)
+ (fn 1) ;alias for lambda (although not officially in Racket)
+ ;; Note: Things matching (rx bos (or "for/" "for*/")) default to
+ ;; racket--indent-for unless otherwise specified here.
+ (for racket--indent-for) ;so the rx can match more strictly
+ (for/lists racket--indent-for/fold)
+ (for/fold racket--indent-for/fold)
+ (for/foldr racket--indent-for/fold)
+ (for* racket--indent-for) ;so the rx can match more strictly
+ (for*/lists racket--indent-for/fold)
+ (for*/fold racket--indent-for/fold)
+ (for*/foldr racket--indent-for/fold)
+ (instantiate 2)
+ (interface 1)
+ (λ defun)
+ (lambda defun)
+ (lambda/kw defun)
+ (let racket--indent-let)
+ (let* 1)
+ (letrec 1)
+ (letrec-values 1)
+ (let-values 1)
+ (let*-values 1)
+ (let+ 1)
+ (let-syntax 1)
+ (let-syntaxes 1)
+ (letrec-syntax 1)
+ (letrec-syntaxes 1)
+ (letrec-syntaxes+values -2)
+ (local 1)
+ (let/cc defun)
+ (let/ec defun)
+ (match 1)
+ (match* 1)
+ (match-define defun)
+ (match-lambda 0)
+ (match-lambda* 0)
+ (match-let 1)
+ (match-let* 1)
+ (match-let*-values 1)
+ (match-let-values 1)
+ (match-letrec 1)
+ (match-letrec-values 1)
+ (match/values 1)
+ (mixin 2)
+ (module 2)
+ (module+ 1)
+ (module* 2)
+ (opt-lambda 1)
+ (parameterize 1)
+ (parameterize-break 1)
+ (parameterize* 1)
+ (place 1)
+ (place/context 1)
+ (quasisyntax/loc 1)
+ (receive 2)
+ (require/typed 1)
+ (require/typed/provide 1)
+ (send* 1)
+ (shared 1)
+ (sigaction 1)
+ (splicing-let 1)
+ (splicing-letrec 1)
+ (splicing-let-values 1)
+ (splicing-letrec-values 1)
+ (splicing-let-syntax 1)
+ (splicing-letrec-syntax 1)
+ (splicing-let-syntaxes 1)
+ (splicing-letrec-syntaxes 1)
+ (splicing-letrec-syntaxes+values -2)
+ (splicing-local 1)
+ (splicing-syntax-parameterize 1)
+ (struct defun)
+ (syntax-case 2)
+ (syntax-case* 3)
+ (syntax-rules 1)
+ (syntax-id-rules 1)
+ (syntax-parse 1)
+ (syntax-parser 0)
+ (syntax-parameterize 1)
+ (syntax/loc 1)
+ (syntax-parse 1)
+ (test-begin 0)
+ (test-case 1)
+ (unit defun)
+ (unit/sig 2)
+ (unless 1)
+ (when 1)
+ (while 1)
+ ;; with- forms default to 1 unless otherwise specified here
+ ))
+ ;; Set property for the plain symbol and also set for the symbol
+ ;; with a : suffix. The latter is for legacy Typed Racket (e.g. both
+ ;; `let` and `let:`). Although Typed Racket doesn't define such a
+ ;; variant for all of these, it's harmless to set the property.
+ (pcase-let* ((`(,plain-sym ,val) spec)
+ (typed-sym (intern (format "%s:" plain-sym))))
+ (dolist (sym (list plain-sym typed-sym))
+ (put sym 'racket-indent-function val))))
+
+(defun racket--escape-string-or-comment ()
+ "If point is in a string or comment, move to its start.
+
+Note that this can be expensive, as it uses `syntax-ppss' which
+parses from the start of the buffer. Although `syntax-ppss' uses
+a cache, that is invalidated after any changes to the buffer. As
+a result, the worst case would be to call this function after
+every character is inserted to a buffer."
+ (when-let (pos (racket--ppss-string/comment-start (syntax-ppss)))
+ (goto-char pos)))
(provide 'racket-indent)
diff --git a/racket-keywords-and-builtins.el b/racket-keywords-and-builtins.el
index a8e175c..9933fc1 100644
--- a/racket-keywords-and-builtins.el
+++ b/racket-keywords-and-builtins.el
@@ -5,15 +5,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(defconst racket-type-list
;; This list was generated using keywords.rkt -- don't edit
@@ -300,6 +292,7 @@
"define-logger"
"define-namespace-anchor"
"define-sequence-syntax"
+ "define-splicing-for-clause-syntax"
"define-struct"
"define-struct/derived"
"define-syntax"
@@ -348,6 +341,7 @@
"for*/foldr"
"for*/foldr/derived"
"for*/hash"
+ "for*/hashalw"
"for*/hasheq"
"for*/hasheqv"
"for*/last"
@@ -359,6 +353,7 @@
"for*/vector"
"for-label"
"for-meta"
+ "for-space"
"for-syntax"
"for-template"
"for/and"
@@ -368,6 +363,7 @@
"for/foldr"
"for/foldr/derived"
"for/hash"
+ "for/hashalw"
"for/hasheq"
"for/hasheqv"
"for/last"
@@ -379,6 +375,9 @@
"for/vector"
"gen:custom-write"
"gen:equal+hash"
+ "gen:equal-mode+hash"
+ "hash-copy-clear"
+ "hash-map/copy"
"if"
"in-bytes"
"in-bytes-lines"
@@ -443,6 +442,7 @@
"module+"
"only-in"
"only-meta-in"
+ "only-space-in"
"open-input-file"
"open-input-output-file"
"open-output-file"
@@ -461,6 +461,7 @@
"quote"
"quote-syntax"
"quote-syntax/prune"
+ "raise-syntax-error"
"regexp-match*"
"regexp-match-peek-positions*"
"regexp-match-positions*"
@@ -522,6 +523,7 @@
"->m"
"/"
":"
+ ":kind"
":print-type"
":query-type/args"
":query-type/result"
@@ -577,6 +579,7 @@
"assoc"
"assq"
"assv"
+ "assw"
"atan"
"augment"
"augment*"
@@ -618,6 +621,7 @@
"blame-update"
"blame-value"
"blame?"
+ "block-device-type-bits"
"boolean=?"
"boolean?"
"bound-identifier=?"
@@ -769,8 +773,11 @@
"char-ci>=?"
"char-ci>?"
"char-downcase"
+ "char-extended-pictographic?"
"char-foldcase"
"char-general-category"
+ "char-grapheme-break-property"
+ "char-grapheme-step"
"char-graphic?"
"char-in"
"char-in/c"
@@ -792,6 +799,7 @@
"char>=?"
"char>?"
"char?"
+ "character-device-type-bits"
"check-duplicate-identifier"
"check-duplicates"
"check-tail-contract"
@@ -846,6 +854,7 @@
"cons/dc"
"cons?"
"const"
+ "const*"
"continuation-mark-key/c"
"continuation-mark-key?"
"continuation-mark-set->context"
@@ -900,6 +909,7 @@
"current-code-inspector"
"current-command-line-arguments"
"current-compile"
+ "current-compile-realm"
"current-compile-target-machine"
"current-compiled-file-roots"
"current-continuation-marks"
@@ -909,12 +919,14 @@
"current-directory-for-user"
"current-drive"
"current-environment-variables"
+ "current-error-message-adjuster"
"current-error-port"
"current-eval"
"current-evt-pseudo-random-generator"
"current-force-delete-permissions"
"current-future"
"current-gc-milliseconds"
+ "current-get-interaction-evt"
"current-get-interaction-input-port"
"current-inexact-milliseconds"
"current-inexact-monotonic-milliseconds"
@@ -950,6 +962,7 @@
"current-seconds"
"current-security-guard"
"current-subprocess-custodian-mode"
+ "current-subprocess-keep-file-descriptors"
"current-syntax-context"
"current-thread"
"current-thread-group"
@@ -989,6 +1002,7 @@
"datum-intern-literal"
"declare-refinement"
"default-continuation-prompt-tag"
+ "default-global-port-print-handler"
"define-compound-unit"
"define-compound-unit/infer"
"define-contract-struct"
@@ -1072,6 +1086,7 @@
"dict-key-contract"
"dict-keys"
"dict-map"
+ "dict-map/copy"
"dict-mutable?"
"dict-ref"
"dict-ref!"
@@ -1088,6 +1103,7 @@
"dict?"
"directory-exists?"
"directory-list"
+ "directory-type-bits"
"disjoin"
"display"
"display-lines"
@@ -1107,6 +1123,7 @@
"dup-output-port"
"dynamic->*"
"dynamic-get-field"
+ "dynamic-instantiate"
"dynamic-object/c"
"dynamic-place"
"dynamic-place*"
@@ -1135,6 +1152,10 @@
"eq-contract?"
"eq-hash-code"
"eq?"
+ "equal-always-hash-code"
+ "equal-always-secondary-hash-code"
+ "equal-always?"
+ "equal-always?/recur"
"equal-contract-val"
"equal-contract?"
"equal-hash-code"
@@ -1145,11 +1166,15 @@
"eqv-hash-code"
"eqv?"
"error"
+ "error-contract->adjusted-string"
"error-display-handler"
"error-escape-handler"
+ "error-message->adjusted-string"
+ "error-message-adjuster-key"
"error-print-context-length"
"error-print-source-location"
"error-print-width"
+ "error-syntax->string-handler"
"error-value->string-handler"
"eval"
"eval-jit-enabled"
@@ -1238,6 +1263,7 @@
"field"
"field-bound?"
"field-names"
+ "fifo-type-bits"
"fifth"
"file->bytes"
"file->bytes-lines"
@@ -1250,6 +1276,7 @@
"file-or-directory-identity"
"file-or-directory-modify-seconds"
"file-or-directory-permissions"
+ "file-or-directory-stat"
"file-or-directory-type"
"file-position"
"file-position*"
@@ -1257,6 +1284,7 @@
"file-stream-buffer-mode"
"file-stream-port?"
"file-truncate"
+ "file-type-bits"
"filename-extension"
"filesystem-change-evt"
"filesystem-change-evt-cancel"
@@ -1301,24 +1329,29 @@
"for*/fold:"
"for*/foldr:"
"for*/hash:"
+ "for*/hashalw:"
"for*/hasheq:"
"for*/hasheqv:"
"for*/last:"
+ "for*/list/concurrent"
"for*/list:"
"for*/lists:"
"for*/mutable-set"
+ "for*/mutable-setalw"
"for*/mutable-seteq"
"for*/mutable-seteqv"
"for*/or:"
"for*/product:"
"for*/set"
"for*/set:"
+ "for*/setalw"
"for*/seteq"
"for*/seteqv"
"for*/stream"
"for*/sum:"
"for*/vector:"
"for*/weak-set"
+ "for*/weak-setalw"
"for*/weak-seteq"
"for*/weak-seteqv"
"for*:"
@@ -1332,24 +1365,29 @@
"for/fold:"
"for/foldr:"
"for/hash:"
+ "for/hashalw:"
"for/hasheq:"
"for/hasheqv:"
"for/last:"
+ "for/list/concurrent"
"for/list:"
"for/lists:"
"for/mutable-set"
+ "for/mutable-setalw"
"for/mutable-seteq"
"for/mutable-seteqv"
"for/or:"
"for/product:"
"for/set"
"for/set:"
+ "for/setalw"
"for/seteq"
"for/seteqv"
"for/stream"
"for/sum:"
"for/vector:"
"for/weak-set"
+ "for/weak-setalw"
"for/weak-seteq"
"for/weak-seteqv"
"for:"
@@ -1392,6 +1430,7 @@
"global-port-print-handler"
"group-by"
"group-execute-bit"
+ "group-permission-bits"
"group-read-bit"
"group-write-bit"
"guard-evt"
@@ -1404,11 +1443,11 @@
"hash-clear"
"hash-clear!"
"hash-copy"
- "hash-copy-clear"
"hash-count"
"hash-empty?"
"hash-ephemeron?"
"hash-eq?"
+ "hash-equal-always?"
"hash-equal?"
"hash-eqv?"
"hash-for-each"
@@ -1440,10 +1479,13 @@
"hash/c"
"hash/dc"
"hash?"
+ "hashalw"
"hasheq"
"hasheqv"
"identifier-binding"
+ "identifier-binding-portal-syntax"
"identifier-binding-symbol"
+ "identifier-distinct-binding"
"identifier-label-binding"
"identifier-prune-lexical-context"
"identifier-prune-to-source-module"
@@ -1543,10 +1585,12 @@
"interface->method-names"
"interface-extension?"
"interface?"
+ "internal-definition-context-add-scopes"
"internal-definition-context-apply"
"internal-definition-context-binding-identifiers"
"internal-definition-context-introduce"
"internal-definition-context-seal"
+ "internal-definition-context-splice-binding-identifier"
"internal-definition-context?"
"invariant-assertion"
"invoke-unit"
@@ -1583,14 +1627,17 @@
"list*of"
"list->bytes"
"list->mutable-set"
+ "list->mutable-setalw"
"list->mutable-seteq"
"list->mutable-seteqv"
"list->set"
+ "list->setalw"
"list->seteq"
"list->seteqv"
"list->string"
"list->vector"
"list->weak-set"
+ "list->weak-setalw"
"list->weak-seteq"
"list->weak-seteqv"
"list-contract?"
@@ -1651,6 +1698,7 @@
"make-environment-variables"
"make-ephemeron"
"make-ephemeron-hash"
+ "make-ephemeron-hashalw"
"make-ephemeron-hasheq"
"make-ephemeron-hasheqv"
"make-exn"
@@ -1689,12 +1737,15 @@
"make-handle-get-preference-locked"
"make-hash"
"make-hash-placeholder"
+ "make-hashalw"
+ "make-hashalw-placeholder"
"make-hasheq"
"make-hasheq-placeholder"
"make-hasheqv"
"make-hasheqv-placeholder"
"make-immutable-custom-hash"
"make-immutable-hash"
+ "make-immutable-hashalw"
"make-immutable-hasheq"
"make-immutable-hasheqv"
"make-impersonator-property"
@@ -1727,6 +1778,7 @@
"make-placeholder"
"make-plumber"
"make-polar"
+ "make-portal-syntax"
"make-predicate"
"make-prefab-struct"
"make-primitive-class"
@@ -1751,7 +1803,10 @@
"make-struct-type-property"
"make-syntax-delta-introducer"
"make-syntax-introducer"
+ "make-temporary-directory"
+ "make-temporary-directory*"
"make-temporary-file"
+ "make-temporary-file*"
"make-tentative-pretty-print-output-port"
"make-thread-cell"
"make-thread-group"
@@ -1760,6 +1815,7 @@
"make-weak-custom-hash"
"make-weak-custom-set"
"make-weak-hash"
+ "make-weak-hashalw"
"make-weak-hasheq"
"make-weak-hasheqv"
"make-will-executor"
@@ -1798,6 +1854,7 @@
"memory-order-release"
"memq"
"memv"
+ "memw"
"merge-input"
"method-in-interface?"
"min"
@@ -1808,12 +1865,15 @@
"module->indirect-exports"
"module->language-info"
"module->namespace"
+ "module->realm"
+ "module-cache-clear!"
"module-compiled-cross-phase-persistent?"
"module-compiled-exports"
"module-compiled-imports"
"module-compiled-indirect-exports"
"module-compiled-language-info"
"module-compiled-name"
+ "module-compiled-realm"
"module-compiled-submodules"
"module-declared?"
"module-path-index-join"
@@ -1828,6 +1888,7 @@
"mpair?"
"mu"
"mutable-set"
+ "mutable-setalw"
"mutable-seteq"
"mutable-seteqv"
"n->th"
@@ -1910,6 +1971,7 @@
"order-of-magnitude"
"ormap"
"other-execute-bit"
+ "other-permission-bits"
"other-read-bit"
"other-write-bit"
"output-port?"
@@ -2026,6 +2088,8 @@
"port-writes-atomic?"
"port-writes-special?"
"port?"
+ "portal-syntax-content"
+ "portal-syntax?"
"positive-integer?"
"positive?"
"pred"
@@ -2033,6 +2097,7 @@
"prefab-key->struct-type"
"prefab-key?"
"prefab-struct-key"
+ "prefab-struct-type-key+field-count"
"preferences-lock-file-mode"
"prefix"
"pregexp"
@@ -2092,6 +2157,7 @@
"procedure-extract-target"
"procedure-impersonator*?"
"procedure-keywords"
+ "procedure-realm"
"procedure-reduce-arity"
"procedure-reduce-arity-mask"
"procedure-reduce-keyword-arity"
@@ -2174,17 +2240,23 @@
"radians->degrees"
"raise"
"raise-argument-error"
+ "raise-argument-error*"
"raise-arguments-error"
+ "raise-arguments-error*"
"raise-arity-error"
+ "raise-arity-error*"
"raise-arity-mask-error"
+ "raise-arity-mask-error*"
"raise-blame-error"
"raise-contract-error"
"raise-mismatch-error"
"raise-not-cons-blame-error"
"raise-range-error"
+ "raise-range-error*"
"raise-result-arity-error"
+ "raise-result-arity-error*"
"raise-result-error"
- "raise-syntax-error"
+ "raise-result-error*"
"raise-type-error"
"raise-user-error"
"random"
@@ -2222,6 +2294,7 @@
"read-curly-brace-with-tag"
"read-decimal-as-inexact"
"read-eval-print-loop"
+ "read-installation-configuration-table"
"read-language"
"read-line"
"read-line-evt"
@@ -2234,6 +2307,7 @@
"read-string!-evt"
"read-string-evt"
"read-syntax"
+ "read-syntax-accept-graph"
"read-syntax/recursive"
"read/recursive"
"readtable-mapping"
@@ -2273,6 +2347,7 @@
"regexp-split"
"regexp-try-match"
"regexp?"
+ "regular-file-type-bits"
"relative-path?"
"relocate-input-port"
"relocate-output-port"
@@ -2286,6 +2361,8 @@
"remq*"
"remv"
"remv*"
+ "remw"
+ "remw*"
"rename"
"rename-contract"
"rename-file-or-directory"
@@ -2357,11 +2434,13 @@
"set-count"
"set-empty?"
"set-eq?"
+ "set-equal-always?"
"set-equal?"
"set-eqv?"
"set-field!"
"set-first"
"set-for-each"
+ "set-group-id-bit"
"set-implements/c"
"set-implements?"
"set-intersect"
@@ -2382,10 +2461,12 @@
"set-symmetric-difference!"
"set-union"
"set-union!"
+ "set-user-id-bit"
"set-weak?"
"set/c"
"set=?"
"set?"
+ "setalw"
"seteq"
"seteqv"
"seventh"
@@ -2407,6 +2488,7 @@
"sixth"
"skip-projection-wrapper?"
"sleep"
+ "socket-type-bits"
"some-system-path->string"
"special-comment-value"
"special-comment?"
@@ -2426,6 +2508,15 @@
"srcloc-source"
"srcloc-span"
"srcloc?"
+ "stencil-vector"
+ "stencil-vector-length"
+ "stencil-vector-mask"
+ "stencil-vector-mask-width"
+ "stencil-vector-ref"
+ "stencil-vector-set!"
+ "stencil-vector-update"
+ "stencil-vector?"
+ "sticky-bit"
"stop-after"
"stop-before"
"stream"
@@ -2481,6 +2572,8 @@
"string-environment-variable-name?"
"string-fill!"
"string-foldcase"
+ "string-grapheme-count"
+ "string-grapheme-span"
"string-join"
"string-len/c"
"string-length"
@@ -2597,6 +2690,7 @@
"symbol<?"
"symbol=?"
"symbol?"
+ "symbolic-link-type-bits"
"symbols"
"sync"
"sync/enable-break"
@@ -2608,11 +2702,14 @@
"syntax-binding-set"
"syntax-binding-set->syntax"
"syntax-binding-set?"
+ "syntax-bound-phases"
+ "syntax-bound-symbols"
"syntax-column"
"syntax-debug-info"
"syntax-disarm"
"syntax-e"
"syntax-line"
+ "syntax-local-apply-transformer"
"syntax-local-bind-syntaxes"
"syntax-local-certifier"
"syntax-local-context"
@@ -2633,6 +2730,7 @@
"syntax-local-match-introduce"
"syntax-local-module-defined-identifiers"
"syntax-local-module-exports"
+ "syntax-local-module-interned-scope-symbols"
"syntax-local-module-required-identifiers"
"syntax-local-name"
"syntax-local-phase-level"
@@ -2787,6 +2885,7 @@
"use-compiled-file-paths"
"use-user-specific-search-paths"
"user-execute-bit"
+ "user-permission-bits"
"user-read-bit"
"user-write-bit"
"value-blame"
@@ -2854,6 +2953,7 @@
"weak-box-value"
"weak-box?"
"weak-set"
+ "weak-setalw"
"weak-seteq"
"weak-seteqv"
"will-execute"
diff --git a/racket-logger.el b/racket-logger.el
index 5414f41..c8db261 100644
--- a/racket-logger.el
+++ b/racket-logger.el
@@ -1,25 +1,18 @@
;;; racket-logger.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'easymenu)
(require 'rx)
(require 'racket-custom)
(require 'racket-repl)
+(require 'racket-back-end)
;; Need to define this before racket-logger-mode
(defvar racket-logger-mode-map
@@ -82,20 +75,29 @@ For more information see:
(setq-local buffer-undo-list t) ;disable undo
(setq-local window-point-insertion-type t))
-(defconst racket--logger-buffer-name "*Racket Logger*")
+(defun racket--logger-buffer-name (&optional back-end-name)
+ (format "*Racket Logger <%s>*" (or back-end-name
+ (racket-back-end-name))))
-(defun racket--logger-get-buffer-create ()
+(defun racket--logger-get-buffer-create (&optional back-end-name)
"Create buffer if necessary. Do not display or select it."
- (unless (get-buffer racket--logger-buffer-name)
- (with-current-buffer (get-buffer-create racket--logger-buffer-name)
- (racket-logger-mode)
- (racket--logger-activate-config)))
- (get-buffer racket--logger-buffer-name))
-
-(defun racket--logger-on-notify (str)
- (when noninteractive ;emacs --batch
- (princ (format "{racket logger}: %s" str)))
- (with-current-buffer (racket--logger-get-buffer-create)
+ (let ((name (racket--logger-buffer-name back-end-name)))
+ (unless (get-buffer name)
+ (with-current-buffer (get-buffer-create name)
+ (racket-logger-mode)
+ (racket--logger-activate-config)))
+ (get-buffer name)))
+
+(defun racket--logger-on-notify (back-end-name str)
+ "This is called from `racket--cmd-dispatch-response'.
+
+As a result, we might create this buffer before the user does a
+`racket-logger-mode' command."
+ (when noninteractive ;emacs --batch
+ (princ (format "{logger %s}: %s"
+ (racket-back-end-name)
+ str)))
+ (with-current-buffer (racket--logger-get-buffer-create back-end-name)
(let* ((inhibit-read-only t)
(original-point (point))
(point-was-at-end-p (equal original-point (point-max))))
@@ -108,7 +110,7 @@ For more information see:
"Send config to logger and display it in the buffer."
(racket--cmd/async nil
`(logger ,racket-logger-config))
- (with-current-buffer (get-buffer-create racket--logger-buffer-name)
+ (with-current-buffer (racket--logger-get-buffer-create)
(let ((inhibit-read-only t))
(goto-char (point-max))
(insert (propertize (concat racket--logger-print-config-prefix
@@ -150,18 +152,19 @@ For more information see:
(interactive)
(racket--logger-get-buffer-create)
;; Give it a window if necessary
- (unless (get-buffer-window racket--logger-buffer-name)
- (display-buffer (get-buffer racket--logger-buffer-name)))
+ (unless (get-buffer-window (racket--logger-buffer-name))
+ (display-buffer (get-buffer (racket--logger-buffer-name))))
;; Select the window
- (select-window (get-buffer-window racket--logger-buffer-name)))
+ (select-window (get-buffer-window (racket--logger-buffer-name))))
(defun racket-logger-clear ()
"Clear the buffer and reconnect."
(interactive)
- (when (y-or-n-p "Clear buffer? ")
- (let ((inhibit-read-only t))
- (delete-region (point-min) (point-max)))
- (racket--logger-activate-config)))
+ (when (eq major-mode 'racket-logger-mode)
+ (when (y-or-n-p "Clear buffer? ")
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max)))
+ (racket--logger-activate-config))))
(defconst racket--logger-item-rx
(rx bol ?\[ (0+ space) (or "fatal" "error" "warning" "info" "debug") ?\] space))
@@ -192,8 +195,6 @@ If N is omitted or nil, move point 1 item backward."
(defun racket-logger-topic-level ()
"Set or unset the level for a topic.
-For convenience, input choices using `ido-completing-read'.
-
The topic labeled \"*\" is the level to use for all topics not
specifically assigned a level.
@@ -201,7 +202,7 @@ The level choice \"*\" means the topic will no longer have its
own level, therefore will follow the level specified for the
\"*\" topic."
(interactive)
- (let* ((topic (ido-completing-read
+ (let* ((topic (completing-read
"Topic: "
(racket--logger-topics)))
(topic (pcase topic
@@ -210,7 +211,7 @@ own level, therefore will follow the level specified for the
(topic (intern topic))
(levels (list "fatal" "error" "warning" "info" "debug"))
(levels (if (eq topic '*) levels (cons "*" levels)))
- (level (ido-completing-read
+ (level (completing-read
(format "Level for topic `%s': " topic)
levels
nil t nil nil
diff --git a/racket-mode.el b/racket-mode.el
index 1585b2f..53c5836 100644
--- a/racket-mode.el
+++ b/racket-mode.el
@@ -1,21 +1,15 @@
;;; racket-mode.el --- Racket editing, REPL, and more -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Package: racket-mode
-;; Package-Requires: ((emacs "25.1") (faceup "0.0.2") (pos-tip "20191127.1028"))
-;; Author: Greg Hendershott
+;; Package-Requires: ((emacs "25.1"))
+;; Author: Greg Hendershott <racket-mode-author@greghendershott.com>
+;; Maintainer: Greg Hendershott
;; URL: https://www.racket-mode.com/
+;; Version: 1
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
@@ -37,6 +31,7 @@
(require 'racket-imenu)
(require 'racket-profile)
(require 'racket-logger)
+(require 'racket-shell)
(require 'racket-stepper)
(require 'racket-repl)
(require 'racket-repl-buffer-name)
@@ -69,6 +64,8 @@
("C-c C-p" racket-cycle-paren-shapes)
("M-C-y" racket-insert-lambda)
("C-c C-d" racket-documentation-search)
+ (("C-c C-s"
+ "C-c C-.") racket-describe-search)
("C-c C-f" racket-fold-all-tests)
("C-c C-u" racket-unfold-all-tests)
((")" "]" "}") racket-insert-closing)))
@@ -126,6 +123,9 @@
["Start Faster" racket-mode-start-faster]
["Customize..." customize-mode]))
+(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")
+
;;;###autoload
(define-derived-mode racket-mode prog-mode
"Racket"
@@ -133,6 +133,7 @@
\\{racket-mode-map}"
(racket--common-variables)
+ (racket-call-racket-repl-buffer-name-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))
@@ -262,7 +263,8 @@ the Racket \"Search Manuals\" page."
(cl-defmethod xref-backend-definitions ((_backend (eql racket-mode-xref)) str)
(or (pcase (get-text-property 0 'racket-module-path str)
(`relative
- (let ((path (expand-file-name (substring-no-properties str 1 -1))))
+ (let ((path (racket--rkt-or-ss-path
+ (expand-file-name (substring-no-properties str 1 -1)))))
(list (xref-make str (xref-make-file-location path 1 0))))))
(list (xref-make str
(xref-make-bogus-location
@@ -273,8 +275,11 @@ the Racket \"Search Manuals\" page."
;;; Commands that predate `racket-xp-mode'
(defun racket-doc ()
- "Instead please use `racket-documentation-search', `racket-xp-documentation' or `racket-repl-documentation'.
-See: <https://github.com/greghendershott/racket-mode/issues/439>"
+ "This command is obsolete.
+
+Instead please use `racket-documentation-search',
+`racket-xp-documentation' or `racket-repl-documentation'. See:
+<https://github.com/greghendershott/racket-mode/issues/439>"
(interactive)
(describe-function 'racket-doc))
diff --git a/racket-parens.el b/racket-parens.el
index 29523b4..1ecf2c0 100644
--- a/racket-parens.el
+++ b/racket-parens.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;; Things related to parens, paredit, electric-pair-mode
@@ -28,12 +20,12 @@
"Simulate a `self-insert-command' of EVENT.
Using this intead of `insert' allows self-insert hooks to run,
-which is important for things like `'electric-pair-mode'.
+which is important for things like `electric-pair-mode'.
-A command using this should probably set its 'delete-selection
+A command using this should probably set its delete-selection
property to t so that `delete-selection-mode' works:
- (put 'racket-command 'delete-selection t)
+ (put \\='racket-command \\='delete-selection t)
If necessary the value of the property can be a function, for
example `racket--electric-pair-mode-not-active'."
@@ -41,10 +33,10 @@ example `racket--electric-pair-mode-not-active'."
(self-insert-command (prefix-numeric-value nil))))
(defun racket--electric-pair-mode-not-active ()
- "A suitable value for the 'delete-selection property of
-commands that insert parens: Inserted text should replace the
-selection unless a mode like `electric-pair-mode' is enabled, in
-which case the selection is to be wrapped in parens."
+ "A suitable value for the delete-selection property of commands
+that insert parens: Inserted text should replace the selection
+unless a mode like `electric-pair-mode' is enabled, in which case
+the selection is to be wrapped in parens."
(not (and (boundp 'electric-pair-mode)
electric-pair-mode)))
@@ -154,14 +146,14 @@ This function is a suitable element for the list variable
(insert open)
(backward-char 1)
(forward-sexp 1)
- (backward-delete-char 1)
+ (delete-char -1)
(insert close))
(_
(user-error "Don't know that paren shape")))))
(defun racket--open-paren (back-func)
"Use BACK-FUNC to find an opening ( [ or { if any.
-BACK-FUNC should be something like #'backward-sexp or #'backward-up-list."
+BACK-FUNC should be something like #\\='backward-sexp or #\\='backward-up-list."
(save-excursion
(ignore-errors
(funcall back-func)
diff --git a/racket-ppss.el b/racket-ppss.el
index 3af8255..29b4c9d 100644
--- a/racket-ppss.el
+++ b/racket-ppss.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;; Note: These doc strings are from the Parser State info topic, as of
;; Emacs 25.1.
@@ -28,30 +20,30 @@ point."
(defun racket--ppss-containing-sexp (xs)
"The character position of the start of the innermost parenthetical
-grouping containing the stopping point; ‘nil’ if none."
+grouping containing the stopping point; nil if none."
(elt xs 1))
(defun racket--ppss-last-sexp (xs)
"The character position of the start of the last complete
-subexpression terminated; ‘nil’ if none.
+subexpression terminated; nil if none.
Valid only for `parse-partial-sexp' -- NOT `syntax-ppss'."
(elt xs 2))
(defun racket--ppss-string-p (xs)
- "Non-‘nil’ if inside a string.
+ "Non-nil if inside a string.
More precisely, this is the character that will terminate the
-string, or ‘t’ if a generic string delimiter character should
+string, or t if a generic string delimiter character should
terminate it."
(elt xs 3))
(defun racket--ppss-comment-p (xs)
- "‘t’ if inside a non-nestable comment (of any comment style;
+ "t if inside a non-nestable comment (of any comment style;
*note Syntax Flags::); or the comment nesting level if inside a
comment that can be nested."
(elt xs 4))
(defun racket--ppss-quote-p (xs)
- "‘t’ if the end point is just after a quote character."
+ "t if the end point is just after a quote character."
(elt xs 5))
(defun racket--ppss-min-paren-depth (xs)
@@ -60,9 +52,9 @@ Valid only for `parse-partial-sexp' -- NOT `syntax-ppss'."
(elt xs 6))
(defun racket--ppss-comment-type (xs)
- "What kind of comment is active: ‘nil’ if not in a comment or
-in a comment of style ‘a’; 1 for a comment of style ‘b’; 2 for a
-comment of style ‘c’; and ‘syntax-table’ for a comment that
+ "What kind of comment is active: nil if not in a comment or
+in a comment of style a; 1 for a comment of style b; 2 for a
+comment of style c; and syntax-table for a comment that
should be ended by a generic comment delimiter character."
(elt xs 7))
@@ -71,7 +63,7 @@ should be ended by a generic comment delimiter character."
While inside a comment, this is the position where the comment
began; while inside a string, this is the position where the
string began. When outside of strings and comments, this element
-is ‘nil’."
+is nil."
(elt xs 8))
(provide 'racket-ppss)
diff --git a/racket-profile.el b/racket-profile.el
index 15f3bcf..415f4e6 100644
--- a/racket-profile.el
+++ b/racket-profile.el
@@ -1,32 +1,21 @@
;;; racket-profile.el -*- lexical-binding: t -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
-
-(require 'cl-lib)
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
(require 'racket-repl)
(require 'racket-util)
+(require 'racket-back-end)
-(defvar racket--profile-project-root nil)
-(defvar racket--profile-results nil)
-(defvar racket--profile-sort-col 1) ;0=Calls, 1=Msec
-(defvar racket--profile-show-zero nil)
-(defvar racket--profile-show-non-project nil)
-(defvar racket--profile-overlay-this nil)
-(defvar racket--profile-overlay-that nil)
+(defvar-local racket--profile-project-root nil)
+(defvar-local racket--profile-results nil)
+(defvar-local racket--profile-show-zero nil)
+(defvar-local racket--profile-show-non-project nil)
(defun racket-profile ()
"Like `racket-run-module-at-point' but with profiling.
@@ -46,7 +35,9 @@ delete compiled/*.zo files."
(unless (eq major-mode 'racket-mode)
(user-error "Works only in a racket-mode buffer"))
(message "Running with profiling instrumentation...")
- (let ((what-to-run (racket--what-to-run)))
+ (let ((buf-name (format "*Racket Profile <%s>*"
+ (racket-back-end-name)))
+ (what-to-run (racket--what-to-run)))
(racket--repl-run
what-to-run
'()
@@ -57,74 +48,104 @@ delete compiled/*.zo files."
(racket--repl-session-id)
`(get-profile)
(lambda (results)
- (message "Profile results ready")
- (with-current-buffer (get-buffer-create "*Racket Profile*")
+ (message "Preparing profile results to display...")
+ (with-current-buffer
+ (get-buffer-create buf-name)
+ (racket-profile-mode)
(setq racket--profile-results results)
- (setq racket--profile-sort-col 1)
(setq racket--profile-project-root
(racket-project-root (car what-to-run)))
- (racket-profile-mode)
(racket--profile-draw)
(pop-to-buffer (current-buffer)))))))))
-(defun racket--profile-refresh ()
+(defun racket-profile-refresh ()
(interactive)
- (setq racket--profile-results
- (racket--cmd/await (racket--repl-session-id)
- `(get-profile)))
- (racket--profile-draw))
+ (racket--cmd/async (racket--repl-session-id)
+ `(get-profile)
+ (lambda (results)
+ (setq racket--profile-results
+ results)
+ (racket--profile-draw))))
(defun racket--profile-draw ()
(setq truncate-lines t) ;let run off right edge
- ;; TODO: Would be nice to set the Calls and Msec column widths based
- ;; on max values.
- (setq header-line-format
- (format " %8s %6s %-30.30s %s"
- (if (= 0 racket--profile-sort-col) "CALLS" "Calls")
- (if (= 1 racket--profile-sort-col) "MSEC" "Msec")
- "Name (inferred)"
- "File"))
(with-silent-modifications
(erase-buffer)
- (let* ((copied (cl-copy-list racket--profile-results))
- (filtered (cl-remove-if-not
- (lambda (x)
- (cl-destructuring-bind (calls msec _name file _beg _end) x
- (and (or racket--profile-show-zero
- (not (and (zerop calls) (zerop msec))))
- (or racket--profile-show-non-project
- (equal (racket-project-root file)
- racket--profile-project-root)))))
- copied))
- (xs (sort filtered
- (lambda (a b) (> (nth racket--profile-sort-col a)
- (nth racket--profile-sort-col b))))))
- (dolist (x xs)
- (cl-destructuring-bind (calls msec name file beg end) x
- (let ((simplified-file
- (if (equal (racket-project-root file)
- racket--profile-project-root)
- (file-relative-name file racket--profile-project-root)
- file)))
- (insert
- (propertize (format "%8d %6d %-30.30s %s\n"
- calls msec (or name "") simplified-file)
- 'racket-profile-location
- (and file beg end
- (list file beg end))))))))
- (newline)
- (insert (concat (if racket--profile-show-zero "Not h" "H")
- "iding 0 calls and 0 msec. Press z to toggle."))
- (newline)
- (insert (concat (if racket--profile-show-non-project "Not h" "H")
- "iding non-project files. Press f to toggle.")))
- (goto-char (point-min)))
-
-(defun racket-profile-sort ()
- "Toggle sort between Calls and Msec."
+ (pcase-let* ((filtered (seq-filter
+ (pcase-lambda (`(,calls ,msec ,_name ,file ,_beg ,_end))
+ (and (or racket--profile-show-zero
+ (not (and (zerop calls) (zerop msec))))
+ (or racket--profile-show-non-project
+ (equal (racket-project-root
+ (racket-file-name-back-to-front file))
+ racket--profile-project-root))))
+ racket--profile-results))
+ (`(,width-calls ,width-msec ,width-name)
+ (seq-reduce (pcase-lambda (`(,width-calls ,width-msec ,width-name)
+ `(,calls ,msec ,name . ,_))
+ (list (max width-calls (length (format "%s" calls)))
+ (max width-msec (length (format "%s" msec)))
+ (max width-name (length name))))
+ filtered
+ `(5 5 4))))
+ (cl-flet ((sort-pred (col) (lambda (a b)
+ (< (string-to-number (aref (cadr a) col))
+ (string-to-number (aref (cadr b) col))))))
+ (setq tabulated-list-format
+ `[("Calls" ,width-calls ,(sort-pred 0) :right-align t)
+ ("Msec" ,width-msec ,(sort-pred 1) :right-align t)
+ ("Name" ,width-name t)
+ ("Source" 99 t)]))
+ (setq tabulated-list-entries
+ (seq-map (pcase-lambda (`(,calls ,msec ,name ,file ,beg ,end))
+ (let* ((file (racket-file-name-back-to-front file))
+ (simplified-file
+ (if (equal (racket-project-root file)
+ racket--profile-project-root)
+ (file-relative-name file racket--profile-project-root)
+ file)))
+ (list nil
+ (vector
+ (format "%s" calls)
+ (format "%s" msec)
+ (propertize (or name "")
+ 'face font-lock-function-name-face)
+ (if (and file beg end)
+ (list simplified-file
+ 'racket-file file
+ 'racket-beg beg
+ 'racket-end end
+ 'action #'racket-profile-button)
+ simplified-file)))))
+ filtered))
+ (tabulated-list-init-header)
+ (tabulated-list-print)
+ (save-excursion
+ (goto-char (point-max))
+ (newline)
+ (insert (concat (if racket--profile-show-zero "Showing" "Hiding")
+ " 0 calls and 0 msec. Press z to toggle."))
+ (newline)
+ (insert (concat (if racket--profile-show-non-project "Showing" "Hiding")
+ " non-project files. Press f to toggle."))))))
+
+(defun racket-profile-button (button)
+ (let ((file (button-get button 'racket-file))
+ (beg (button-get button 'racket-beg)))
+ (xref-push-marker-stack)
+ (find-file file)
+ (goto-char beg)))
+
+(defun racket-profile-visit ()
+ "Visit the source of the profile item.
+
+Use \\[xref-pop-marker-stack] -- `xref-pop-marker-stack' -- to return."
(interactive)
- (setq racket--profile-sort-col (if (= racket--profile-sort-col 0) 1 0))
- (racket--profile-draw))
+ (pcase (tabulated-list-get-entry (point))
+ (`[,_calls ,_msec ,_name (,_ racket-file ,file racket-beg ,beg . ,_)]
+ (xref-push-marker-stack)
+ (find-file file)
+ (goto-char beg))))
(defun racket-profile-show-zero ()
"Toggle between showing results with zero Calls or Msec."
@@ -140,40 +161,6 @@ The \"project\" is determined by `racket-project-root'."
(setq racket--profile-show-non-project (not racket--profile-show-non-project))
(racket--profile-draw))
-(defun racket--profile-visit ()
- (interactive)
- (let ((win (selected-window)))
- (pcase (get-text-property (point) 'racket-profile-location)
- (`(,file ,beg ,end)
- (setq racket--profile-overlay-this
- (make-overlay (save-excursion (beginning-of-line) (point))
- (save-excursion (end-of-line) (point))
- (current-buffer)))
- (overlay-put racket--profile-overlay-this 'face 'next-error)
- (find-file-other-window file)
- (setq racket--profile-overlay-that (make-overlay beg end (current-buffer)))
- (overlay-put racket--profile-overlay-that 'face 'next-error)
- (goto-char beg)
- (add-hook 'pre-command-hook #'racket--profile-remove-overlay)
- (select-window win)))))
-
-(defun racket--profile-remove-overlay ()
- (delete-overlay racket--profile-overlay-this)
- (delete-overlay racket--profile-overlay-that)
- (remove-hook 'pre-command-hook #'racket--profile-remove-overlay))
-
-(defun racket-profile-next ()
- "Do `forward-line' and show the source in other window."
- (interactive)
- (forward-line 1)
- (racket--profile-visit))
-
-(defun racket-profile-prev ()
- "Do `previous-line' and show the source in other window."
- (interactive)
- (forward-line -1)
- (racket--profile-visit))
-
(defvar racket-profile-mode-map
(let ((m (make-sparse-keymap)))
(set-keymap-parent m nil)
@@ -181,21 +168,21 @@ The \"project\" is determined by `racket-project-root'."
(define-key m (kbd (car x)) (cadr x)))
'(("q" quit-window)
("g" racket-profile-refresh)
- ("n" racket-profile-next)
- ("p" racket-profile-prev)
("z" racket-profile-show-zero)
("f" racket-profile-show-non-project)
- ("," racket-profile-sort)))
+ ("." racket-profile-visit)
+ ("RET" racket-profile-visit)))
m)
"Keymap for Racket Profile mode.")
-(define-derived-mode racket-profile-mode special-mode
+(define-derived-mode racket-profile-mode tabulated-list-mode
"RacketProfile"
"Major mode for results of `racket-profile'.
\\{racket-profile-mode-map}
"
- (setq show-trailing-whitespace nil))
+ (setq show-trailing-whitespace nil)
+ (setq tabulated-list-sort-key '("Calls" . t)))
(provide 'racket-profile)
diff --git a/racket-repl-buffer-name.el b/racket-repl-buffer-name.el
index 719acfa..58c7156 100644
--- a/racket-repl-buffer-name.el
+++ b/racket-repl-buffer-name.el
@@ -1,32 +1,34 @@
;;; racket-repl-buffer-name.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+(require 'racket-back-end)
(require 'racket-custom)
(require 'racket-repl)
(require 'racket-util)
+(require 'tramp)
+
+;;;###autoload
+(defun racket-call-racket-repl-buffer-name-function ()
+ (funcall (or (and (functionp racket-repl-buffer-name-function)
+ racket-repl-buffer-name-function)
+ #'racket-repl-buffer-name-shared)))
;;;###autoload
(defun racket-repl-buffer-name-shared ()
- "All `racket-mode' edit buffers share one `racket-repl-mode' buffer.
+ "All `racket-mode' edit buffers share one `racket-repl-mode' buffer per back end.
A value for the variable `racket-repl-buffer-name-function'."
(interactive)
- (setq-default racket-repl-buffer-name "*Racket REPL*"))
+ (setq-local racket-repl-buffer-name
+ (format "*Racket REPL <%s>*"
+ (racket-back-end-name))))
;;;###autoload
(defun racket-repl-buffer-name-unique ()
@@ -47,7 +49,8 @@ The \"project\" is determined by `racket-project-root'."
(interactive)
(setq-local racket-repl-buffer-name
(format "*Racket REPL <%s>*"
- (racket-project-root (racket--buffer-file-name)))))
+ (racket--file-name-sans-remote-method
+ (racket-project-root (racket--buffer-file-name))))))
(defun racket-mode-maybe-offer-to-kill-repl-buffer ()
"Maybe offer to kill a `racket-repl-mode' buffer.
diff --git a/racket-repl.el b/racket-repl.el
index b9c2600..f1dc8ef 100644
--- a/racket-repl.el
+++ b/racket-repl.el
@@ -1,32 +1,27 @@
;;; racket-repl.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Image portions Copyright (C) 2012 Jose Antonio Ortega Ruiz.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-browse-url)
+(require 'racket-company-doc)
(require 'racket-complete)
(require 'racket-describe)
(require 'racket-doc)
(require 'racket-eldoc)
(require 'racket-custom)
(require 'racket-common)
+(require 'racket-show)
(require 'racket-util)
(require 'racket-visit)
(require 'racket-cmd)
+(require 'racket-back-end)
(require 'comint)
(require 'compile)
(require 'easymenu)
@@ -36,9 +31,10 @@
(require 'xref)
(require 'semantic/symref/grep)
+(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--debug-send-definition "racket-debug" (beg end))
-(autoload 'racket--debug-send-definition "racket-debug")
(declare-function racket--debuggable-files "racket-debug" (file-to-run))
(autoload 'racket--debuggable-files "racket-debug")
@@ -65,7 +61,7 @@
;; 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 "*Racket REPL*"
+(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
@@ -96,17 +92,21 @@ The result might be nil if no REPL buffer exists, or if it does
but does not have a live session."
(if (eq major-mode 'racket-repl-mode)
racket--repl-session-id
- (let ((buffer (get-buffer racket-repl-buffer-name)))
- (when buffer
- (with-current-buffer racket-repl-buffer-name
- racket--repl-session-id)))))
+ (when (stringp racket-repl-buffer-name)
+ (let ((buffer (get-buffer racket-repl-buffer-name)))
+ (when buffer
+ (with-current-buffer racket-repl-buffer-name
+ racket--repl-session-id))))))
(defun racket--call-with-repl-buffer (thunk)
- (pcase (get-buffer (if (eq major-mode 'racket-repl-mode)
- (buffer-file-name)
- racket-repl-buffer-name))
- ((and (pred bufferp) buf)
- (with-current-buffer buf (funcall 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."
@@ -122,7 +122,7 @@ but does not have a live session."
(defun racket-repl--input-filter (str)
"Don't save anything matching `racket-history-filter-regexp'."
- (not (string-match racket-history-filter-regexp str)))
+ (not (string-match-p racket-history-filter-regexp str)))
(defalias 'racket-repl-eval-or-newline-and-indent #'racket-repl-submit)
@@ -130,13 +130,15 @@ but does not have a live session."
"Submit your input to the Racket REPL.
If the REPL is running a Racket lang whose language-info has a
-'drracket:submit-predicate, that is first called to see if the
+drracket:submit-predicate, that is first called to see if the
input is valid to be submitted.
-With \\[universal-argument] 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."
+\\<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")))
@@ -147,34 +149,41 @@ expression/statement."
`(repl-submit? ,text t))
((t) t)
((nil) (user-error "Not a complete expression, according to the current lang's submit-predicate."))
- ((default) (racket--repl-complete-sexp-p proc)))
- (racket--repl-complete-sexp-p proc))))
- (if (not submitp)
- (newline-and-indent)
- (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)))))
-
-(defun racket--repl-complete-sexp-p (proc)
+ ((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."
(condition-case nil
- (let* ((beg (marker-position (process-mark proc)))
- (end (save-excursion
- (goto-char beg)
- (forward-list 1) ;scan-error unless complete sexp
- (point)))
- (blankp (save-excursion
- (save-match-data
- (goto-char beg)
- (equal end
- (re-search-forward (rx (1+ (or (syntax whitespace)
- (syntax comment-start)
- (syntax comment-end))))
- end
- t))))))
- (not (or (equal beg end) blankp)))
+ (let* ((beg (marker-position (process-mark proc)))
+ (end (save-excursion
+ (goto-char beg)
+ (while (< (point) (point-max))
+ ;; This will scan-error unless complete sexp, or
+ ;; all whitespace.
+ (forward-list 1))
+ (point))))
+ (not (or (equal beg end) ;nothing
+ (string-match-p ;something but all whitespace
+ (rx bos
+ (1+ (or (syntax whitespace)
+ (syntax comment-start)
+ (syntax comment-end)))
+ eos)
+ (buffer-substring beg end)))))
(scan-error nil)))
(defun racket-repl-break ()
@@ -194,8 +203,11 @@ 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\".
-With \\[universal-argument] terminates the entire Racket Mode
-back end process --- the command server and all REPL sessions."
+\\<racket-repl-mode-map>
+With a prefix argument (e.g. \\[universal-argument] \\[racket-repl-exit]):
+
+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")
@@ -205,6 +217,9 @@ back end process --- the command server and all REPL sessions."
(t
(user-error "Back end is not running"))))
+(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")
+
;;;###autoload
(defun racket-repl (&optional noselect)
"Show a Racket REPL buffer in some window.
@@ -212,20 +227,22 @@ back end process --- the command server and all REPL sessions."
*IMPORTANT*
The main, intended use of Racket Mode's REPL is that you
-`find-file' some specific .rkt file, then `racket-run' it. The
-REPL will then match that file.
+`find-file' some specific .rkt file, then run it using
+`racket-run' or `racket-run-module-at-point'. The resulting REPL
+will correspond to those definitions and match your expectations.
-If the REPL isn't running, and you want to start it for no file
-in particular? Then you could use this command. But the resulting
+If you really want to start a REPL for no file in particular,
+then you could use this `racket-repl' command. But the resulting
REPL will have a minimal \"#lang racket/base\" namespace. You
could enter \"(require racket)\" if you want the equivalent of
\"#lang racket\". You could also \"(require racket/enter)\" if
you want things like \"enter!\". But in some sense you'd be
-\"using it wrong\". If you really don't want to use Racket Mode's
-REPL as intended, then you might as well use a plain Emacs shell
-buffer to run command-line Racket."
+\"using it wrong\". If you actually don't want to use Racket
+Mode's REPL as intended, then consider using a plain Emacs
+`shell' buffer to run command-line Racket."
(interactive "P")
- (cl-labels
+ (racket-call-racket-repl-buffer-name-function)
+ (cl-flet
((display-and-maybe-select
()
(display-buffer racket-repl-buffer-name)
@@ -256,12 +273,27 @@ runs the submodules specified by the customization variable
See also `racket-run-module-at-point', which runs just the
specific module at point.
-With \\[universal-argument] uses errortrace for improved stack traces.
-Otherwise follows the `racket-error-context' setting.
+The command varies based on how many \\[universal-argument]
+prefix arguments you supply.
+\\<racket-mode-map>
-With \\[universal-argument] \\[universal-argument] instruments
-code for step debugging. See `racket-debug-mode' and the variable
-`racket-debuggable-files'.
+- \\[racket-run-and-switch-to-repl]
+
+ Follows the `racket-error-context' setting.
+
+- \\[universal-argument] \\[racket-run-and-switch-to-repl]
+
+ Uses errortrace for improved stack traces, as if
+ `racket-error-context' were set to \"high\".
+
+ This lets you keep `racket-error-context' set to a faster
+ value like \"low\" or \"medium\", then conveniently re-run
+ when you need a better strack trace.
+
+- \\[universal-argument] \\[universal-argument] \\[racket-run-and-switch-to-repl]
+
+ Instruments code for step debugging. See `racket-debug-mode'
+ and the variable `racket-debuggable-files'.
Each run occurs within a Racket custodian. Any prior run's
custodian is shut down, releasing resources like threads and
@@ -315,6 +347,7 @@ simply the outermost, file module."
(defun racket-run-with-errortrace ()
"Run with `racket-error-context' temporarily set to \"high\".
+\\<racket-mode-map>
This is equivalent to \\[universal-argument] \\[racket-run].
Defined as a function so it can be a menu target."
@@ -322,8 +355,9 @@ Defined as a function so it can be a menu target."
(racket-run '(4)))
(defun racket-run-with-debugging ()
- "Run with `racket-error-context' temporarily set to 'debug.
+ "Run with `racket-error-context' temporarily set to \"debug\".
+\\<racket-mode-map>
This is equivalent to \\[universal-argument] \\[universal-argument] \\[racket-run].
Defined as a function so it can be a menu target."
@@ -335,6 +369,7 @@ Defined as a function so it can be a menu target."
This is similar to how Dr Racket behaves.
+\\<racket-mode-map>
To make it even more similar, you may add `racket-repl-clear' to
the variable `racket-before-run-hook'."
(interactive "P")
@@ -348,7 +383,7 @@ the variable `racket-before-run-hook'."
(display-buffer racket-repl-buffer-name)
(select-window (get-buffer-window racket-repl-buffer-name t)))))
-(defun racket-test (&optional coverage)
+(defun racket-test (&optional prefix)
"Run the \"test\" submodule.
Put your tests in a \"test\" submodule. For example:
@@ -362,43 +397,52 @@ Put your tests in a \"test\" submodule. For example:
Any rackunit test failure messages show the location. You may use
`next-error' to jump to the location of each failing test.
-With \\[universal-argument] also runs the tests with coverage
-instrumentation and highlights uncovered code using
-`font-lock-warning-face'.
+With \\[universal-argument] uses errortrace for improved stack traces.
+Otherwise follows the `racket-error-context' setting.
+
+With \\[universal-argument] \\[universal-argument] also runs the
+tests with coverage instrumentation and highlights uncovered code
+using `font-lock-warning-face'.
See also:
- `racket-fold-all-tests'
- `racket-unfold-all-tests'
"
(interactive "P")
- (let ((mod-path (list 'submod (racket--buffer-file-name) 'test))
+ (let ((mod-path (list (racket--buffer-file-name) 'test))
(buf (current-buffer)))
- (if (not coverage)
- (racket--repl-run mod-path)
- (message "Running test submodule with coverage instrumentation...")
- (racket--repl-run
- mod-path
- '()
- 'coverage
- (lambda ()
- (message "Getting coverage results...")
- (racket--cmd/async
- (racket--repl-session-id)
- `(get-uncovered)
- (lambda (xs)
- (pcase xs
- (`() (message "Full coverage."))
- ((and xs `((,beg0 . ,_) . ,_))
- (message "Missing coverage in %s place(s)." (length xs))
- (with-current-buffer buf
- (with-silent-modifications
- (overlay-recenter (point-max))
- (dolist (x xs)
- (let ((o (make-overlay (car x) (cdr x) buf)))
- (overlay-put o 'name 'racket-uncovered-overlay)
- (overlay-put o 'priority 100)
- (overlay-put o 'face font-lock-warning-face)))
- (goto-char beg0))))))))))))
+ ;; Originally this function's single optional argument was a
+ ;; `coverage-p` boolean. For backward compatibility in case anyone
+ ;; has Emacs Lisp calling this function non-interactively, we keep
+ ;; supporting t and nil values.
+ (pcase prefix
+ (`() (racket--repl-run mod-path))
+ (`(4) (racket--repl-run mod-path nil 'high))
+ ((or '(16) 't)
+ (message "Running test submodule with coverage instrumentation...")
+ (racket--repl-run
+ mod-path
+ nil
+ 'coverage
+ (lambda ()
+ (message "Getting coverage results...")
+ (racket--cmd/async
+ (racket--repl-session-id)
+ `(get-uncovered)
+ (lambda (xs)
+ (pcase xs
+ (`() (message "Full coverage."))
+ ((and xs `((,beg0 . ,_) . ,_))
+ (message "Missing coverage in %s place(s)." (length xs))
+ (with-current-buffer buf
+ (with-silent-modifications
+ (overlay-recenter (point-max))
+ (dolist (x xs)
+ (let ((o (make-overlay (car x) (cdr x) buf)))
+ (overlay-put o 'name 'racket-uncovered-overlay)
+ (overlay-put o 'priority 100)
+ (overlay-put o 'face font-lock-warning-face)))
+ (goto-char beg0)))))))))))))
(add-hook 'racket--repl-before-run-hook #'racket--remove-coverage-overlays)
@@ -431,7 +475,7 @@ For example:
The following values will /not/ work:
#+BEGIN_SRC elisp
- '(\"-f\" \"bar\")
+ \\='(\"-f\" \"bar\")
(list \"-f\" \"bar\")
#+END_SRC
")
@@ -451,42 +495,100 @@ for end user customization is `racket-after-run-hook'.
Here \"after\" means that the run has completed and e.g. the REPL
is waiting at another prompt.")
-(defun racket--repl-run (&optional what-to-run extra-submods context-level callback)
+(defun racket--repl-run (&optional what extra-submods context-level callback)
"Do an initial or subsequent run.
-WHAT-TO-RUN should be a cons of a file name to a list of
-submodule symbols. Or if nil, defaults to `racket--what-to-run'.
+WHAT must be `racket--what-to-run-p', where nil defaults to
+`racket--what-to-run'.
EXTRA-SUBMODS should be a list of symbols, names of extra
-submodules to run, e.g. '(test main). This is intended for use by
+submodules to run, e.g. (test main). This is intended for use by
`racket-run', which more closely emulates DrRacket, as opposed to
`racket-run-module-at-point'.
CONTEXT-LEVEL should be a valid value for the variable
-`racket-error-context', 'coverage, or 'profile. Or if nil,
+`racket-error-context', \"coverage\", or \"profile\". Or if nil,
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.
+be nil which is equivalent to #\\='ignore.
-- If the REPL is not live, create it.
+If not `racket--repl-live-p', start it and supply the run
+command via the start callback.the REPL is not live, create it.
-- If the REPL is live, send a 'run command to the backend's TCP
- server."
+Otherwise if `racket--repl-live-p', send the command."
(unless (eq major-mode 'racket-mode)
- (user-error "Only works from a `racket-mode' buffer"))
+ (user-error "Racket Mode run command only works from a `racket-mode' buffer"))
+ ;; Support running buffers created by `org-edit-src-code': see
+ ;; issues #626, #630.
+ (when (bound-and-true-p org-src-mode)
+ (unless buffer-file-name
+ ;; Give the buffer a temp file we can run. The correct thing to
+ ;; use is `set-visited-file-name', which handles many things
+ ;; besides setting `buffer-file-name'. Some we want, e.g.
+ ;; setting the buffer-modified flag. Some we don't, e.g.
+ ;; renaming the buffer, which we rename back to the original
+ ;; because org-src does things with regexps on these buffer
+ ;; names.
+ (let ((orig-buffer-name (buffer-name)))
+ (set-visited-file-name (make-temp-file "racket-org-edit-" nil ".rkt"))
+ (rename-buffer orig-buffer-name))
+ (setq what (list (racket--buffer-file-name)))
+ ;; org-src adds to `write-contents-functions' a hook that
+ ;; prevents `save-buffer' actually writing to file; instead it
+ ;; copies contents back to the main org buffer. Accommodate that
+ ;; by prepending our own hook, which actually writes to file. It
+ ;; returns nil to mean other hooks should still be run, so this
+ ;; doesn't interfere with org's hook.
+ (add-hook 'write-contents-functions #'racket--write-contents nil t)))
+ ;; Save buffer and validate WHAT to run.
+ (unless (progn (racket--save-if-changed)
+ (racket--what-to-run-p what))
+ (signal 'wrong-type-argument `(racket--what-to-run-p ,what)))
+ ;; Handle the restart-watch-directories feature; #602
+ (when-let (changes (racket--back-end-watch-read/reset))
+ (when (y-or-n-p (format "Changed: %S -- restart Racket Mode back end %S? "
+ 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) ;users'
- (let* ((cmd (racket--repl-make-run-command (or what-to-run (racket--what-to-run))
- extra-submods
- (or context-level racket-error-context)))
- (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) ;users'
- (when callback
- (funcall callback))))))
+ (run-hook-with-args 'racket-before-run-hook) ;user's
+ (pcase-let*
+ ((context-level (or context-level racket-error-context))
+ (what (or what (racket--what-to-run)))
+ (`(,what ,debug-files)
+ (pcase what
+ (`(,file . ,subs)
+ (list (cons (racket-file-name-front-to-back file) subs)
+ (when (eq context-level 'debug)
+ (racket--debuggable-files file))))
+ (`()
+ (list nil nil))))
+ (cmd (list 'run
+ what
+ extra-submods
+ racket-memory-limit
+ racket-pretty-print
+ (window-width)
+ (racket--char-pixel-width)
+ context-level
+ racket-user-command-line-arguments
+ debug-files))
+ (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
+ (when callback
+ (funcall callback))))))
(cond ((racket--repl-live-p)
(unless (racket--repl-session-id)
(error "No REPL session"))
@@ -503,21 +605,9 @@ be nil which is equivalent to #'ignore.
(racket--cmd/async (racket--repl-session-id) cmd after)
(display-buffer racket-repl-buffer-name))))))))
-(defun racket--repl-make-run-command (what-to-run extra-submods context-level)
- "Form a `run` command sexpr for the backend.
-WHAT-TO-RUN may be nil, meaning just a `racket/base` namespace."
- (let ((context-level (or context-level racket-error-context)))
- (list 'run
- what-to-run
- extra-submods
- racket-memory-limit
- racket-pretty-print
- (window-width)
- (racket--char-pixel-width)
- context-level
- racket-user-command-line-arguments
- (when (and what-to-run (eq context-level 'debug))
- (racket--debuggable-files (car what-to-run))))))
+(defun racket--write-contents ()
+ (write-region nil nil buffer-file-name)
+ nil)
(defun racket--char-pixel-width ()
(with-temp-buffer
@@ -532,73 +622,84 @@ WHAT-TO-RUN may be nil, meaning just a `racket/base` namespace."
Sets `racket--repl-session-id'.
This does not display the buffer or change the selected window."
- ;; 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.
(when noninteractive (princ "{racket--repl-start}: entered\n"))
- (racket--cmd/async
- nil
- `(repl-tcp-port-number)
- (lambda (repl-tcp-port-number)
- (when noninteractive
- (princ (format "{racket--repl-start}: (repl-tcp-port-number) replied %s\n" repl-tcp-port-number)))
- (with-current-buffer (get-buffer-create racket-repl-buffer-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)
- (when noninteractive
- (princ (format "{racket--repl-start}: %s\n" id)))
- (setq racket--repl-session-id id)
- (run-with-timer 0.001 nil callback)
- (remove-hook 'comint-preoutput-filter-functions hook t)
- (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 ()
- (progn
- (make-comint-in-buffer racket-repl-buffer-name
- (current-buffer)
- (cons "127.0.0.1" repl-tcp-port-number))
- (process-send-string (get-buffer-process (current-buffer))
- (format "\"%s\"\n" racket--cmd-auth))
- (when noninteractive
- (princ "{racket--repl-start}: did process-send-string of auth\n"))
- (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)
+ ;; 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 "{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 server at 127.0.0.1:%s" repl-tcp-port-number)))))))
+ (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?")))))))))
;;; Misc
@@ -644,27 +745,34 @@ most recent `racket-mode' buffer, if any."
;;; send to REPL
-(defun racket--send-region-to-repl (start end)
+(defun racket--send-region-to-repl (start end &optional echo-p)
"Internal function to send the region to the Racket REPL.
-Before sending the region, calls `racket-repl' and
-`racket--repl-forget-errors'. Also inserts a ?\n at the process
-mark so that output goes on a fresh line, not on the same line as
-the prompt.
+Requires the REPL already to be started, e.g. from a run command.
+
+Before sending the region, calls `racket--repl-forget-errors'.
+Also inserts a ?\n at the process mark so that output goes on a
+fresh line, not on the same line as the prompt.
-Afterwards displays the buffer in some window."
+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)
+ (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.
(let ((source-buffer (current-buffer)))
- (racket-repl t)
(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)
@@ -678,48 +786,68 @@ Afterwards displays the buffer in some window."
(user-error "No region"))
(racket--send-region-to-repl start end))
-(defun racket-send-definition (&optional prefix)
+(defun racket-send-definition ()
"Send the current definition to the Racket REPL."
- (interactive "P")
+ (interactive)
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
- (if prefix
- (racket--debug-send-definition (point) end)
- (racket--send-region-to-repl (point) end)))))
+ (racket--send-region-to-repl (point) end))))
-(defun racket-send-last-sexp ()
- "Send the previous sexp to the Racket REPL.
+(defun racket-send-last-sexp (&optional prefix)
+ "Send the expression before point to the Racket REPL.
-When the previous sexp is a sexp comment the sexp itself is sent,
-without the #; prefix."
- (interactive)
- (racket--send-region-to-repl (racket--repl-last-sexp-start)
- (point)))
+The expression may be either an at-expression or an s-expression.
+
+When the expression is a sexp comment, the sexp itself is sent,
+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
+from the zero or more values to which it evaluates."
+ (interactive "P")
+ (racket--send-region-to-repl (racket--start-of-previous-expression)
+ (point)
+ prefix))
(defun racket-eval-last-sexp ()
- "Eval the previous sexp asynchronously and `message' the result."
+ "Eval the expression before point asynchronously.
+
+The eventual results are presented using the variable
+`racket-show-functions'.
+
+The expression may be either an at-expression or an s-expression."
(interactive)
(unless (racket--repl-live-p)
- (user-error "No REPL session available"))
- (racket--cmd/async
- (racket--repl-session-id)
- `(eval
- ,(buffer-substring-no-properties (racket--repl-last-sexp-start)
- (point)))
- (lambda (v)
- (message "%s" v))))
-
-(defun racket--repl-last-sexp-start ()
+ (user-error "No REPL session available; run the file first"))
+ (let ((beg (racket--start-of-previous-expression))
+ (end (point)))
+ (racket--cmd/async
+ (racket--repl-session-id)
+ `(eval ,(buffer-substring-no-properties beg end))
+ (lambda (v)
+ (racket-show (format "%s" v) end t)))))
+
+(defun racket--start-of-previous-expression ()
+ "Handles both s-expressions and at-expressions."
(save-excursion
- (condition-case ()
- (progn
- (backward-sexp)
- (if (save-match-data (looking-at "#;"))
- (+ (point) 2)
- (point)))
- (scan-error (user-error "There isn't a complete s-expression before point")))))
+ (cl-flet* ((back () (and (< (point-min) (point))
+ (ignore-errors (backward-sexp) t)))
+ (back-to (ch) (and (back)
+ (eq (char-after (point)) ch)))
+ (back-to* (&rest chs) (let ((pt (point)))
+ (or (seq-every-p #'back-to chs)
+ (progn (goto-char pt) nil)))))
+ (or (back-to* ?\{ ?\[ ?@) ;@~a["foo"]{bar}
+ (back-to* ?\{ ?@) ;@~a{abc}
+ (back-to* ?\[ ?@) ;@+[1 2]
+ (back) ;@(+ 1 2) @1 or any s-expression
+ (user-error "No previous s-expression or at-expression"))
+ (if (looking-at-p "#;")
+ (+ (point) 2)
+ (point)))))
(defun racket--repl-forget-errors ()
"Forget existing errors in the REPL.
@@ -763,7 +891,7 @@ Although they remain clickable they will be ignored by
(defun racket-repl--clean-image-cache ()
"Clean all except for the last `racket-images-keep-last'
-images in 'racket-image-cache-dir'."
+images in `racket-image-cache-dir'."
(interactive)
(dolist (file (butlast (racket-repl--list-image-cache)
racket-images-keep-last))
@@ -786,19 +914,22 @@ A value for the variable `comint-output-filter-functions'."
pmark
t)
(let* ((beg (match-beginning 0))
- (file (match-string-no-properties 1)))
+ (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 ;file not data
- (append
- '(:scale 1.0) ;#529
- (and (image-type-available-p 'imagemagick)
- racket-imagemagick-props)))))
+ (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)))
@@ -870,7 +1001,7 @@ to supply this quickly enough or at all."
:company-location #'racket--repl-company-location))))
(defun racket--repl-company-doc-buffer (str)
- (racket--do-describe 'namespace (racket--repl-session-id) str))
+ (racket--company-doc-buffer 'namespace str))
(defun racket--repl-company-location (str)
(pcase (racket--cmd/await (racket--repl-session-id)
@@ -909,63 +1040,48 @@ A more satisfying experience is to use `racket-repl-describe' or
;;; describe
(defun racket-repl-describe (&optional prefix)
- "Describe the identifier at point in a `*Racket Describe*` buffer.
+ "Describe the identifier at point.
-The command varies based on how many \\[universal-argument]
-command prefixes you supply.
-
-0. None.
+The command varies based on how many \\[universal-argument] prefix arguments you supply.
+\\<racket-repl-mode-map>
- Uses the symbol at point. If no such symbol exists, you are
- prompted enter the identifier, but in this case it only
- considers definitions or imports at the file's module level --
- not local bindings nor definitions in submodules.
+- \\[racket-repl-describe]
- - If the identifier has installed Racket documentation, then a
- simplified version of the HTML is presented in the buffer,
- including the \"blue box\", documentation prose, and
- examples.
+ Uses the symbol at point. If no such symbol exists, you are
+ prompted enter the identifier, but in this case it only
+ considers definitions or imports at the file's module level --
+ not local bindings nor definitions in submodules.
- - Otherwise, if the identifier is a function, then its
- signature is displayed, for example \"\(name arg-1-name
- arg-2-name\)\".
+ - If the identifier has installed Racket documentation, then a
+ simplified version of the HTML is presented in the buffer,
+ including the \"blue box\", documentation prose, and
+ examples.
-1. \\[universal-argument]
+ - Otherwise, if the identifier is a function, then its
+ signature is displayed, for example \"\(name arg-1-name
+ arg-2-name\)\".
- Always prompts you to enter a symbol, defaulting to the symbol
- at point if any.
+- \\[universal-argument] \\[racket-repl-describe]
- Otheriwse behaves like 0.
+ Always prompts you to enter a symbol, defaulting to the symbol
+ at point if any.
-2. \\[universal-argument] \\[universal-argument]
+- \\[universal-argument] \\[universal-argument] \\[racket-repl-describe]
- This is an alias for `racket-search-describe', which uses
- installed documentation in a `racket-describe-mode' buffer
- instead of an external web browser.
+ This is an alias for `racket-describe-search', which uses
+ installed documentation in a `racket-describe-mode' buffer
+ instead of an external web browser.
The intent is to give a quick reminder or introduction to
something, regardless of whether it has installed documentation
--- and to do so within Emacs, without switching to a web browser.
-
-You can quit the buffer by pressing q. Also, at the bottom of the
-buffer are Emacs buttons -- which you may navigate among using
-TAB, and activate using RET -- for `xref-find-definitions'
-and `racket-repl-documentation'."
+-- and to do so within Emacs, without switching to a web browser."
(interactive "P")
(if (equal prefix '(16))
- (racket-search-describe)
+ (racket-describe-search)
(pcase (racket--symbol-at-point-or-prompt prefix "Describe: "
racket--repl-namespace-symbols)
((and (pred stringp) str)
- (let ((repl-session-id (racket--repl-session-id)))
- (racket--do-describe
- 'namespace
- repl-session-id
- str
- t
- (pcase (xref-backend-definitions 'racket-repl-xref str)
- (`(,xref) (lambda () (racket--pop-to-xref-location xref))))
- (lambda () (racket--doc-command repl-session-id 'namespace str))))))))
+ (racket--do-describe 'namespace (racket--repl-session-id) str)))))
;;; racket-xref-repl
@@ -987,13 +1103,23 @@ and `racket-repl-documentation'."
(`absolute
(pcase (racket--cmd/await nil `(mod ,(substring-no-properties str)))
(`(,path ,line ,col)
- (list (xref-make str (xref-make-file-location path line col))))))
+ (list
+ (xref-make str
+ (xref-make-file-location (racket-file-name-back-to-front path)
+ line col))))))
(`relative
- (let ((path (expand-file-name (substring-no-properties str 1 -1))))
- (list (xref-make str (xref-make-file-location path 1 0))))))
+ (let ((path (racket--rkt-or-ss-path
+ (expand-file-name (substring-no-properties str 1 -1)))))
+ (list
+ (xref-make str
+ (xref-make-file-location (racket-file-name-back-to-front path)
+ 1 0))))))
(pcase (racket--cmd/await racket--repl-session-id `(def namespace ,str))
(`(,path ,line ,col)
- (list (xref-make str (xref-make-file-location path line col))))
+ (list
+ (xref-make str
+ (xref-make-file-location (racket-file-name-back-to-front path)
+ line col))))
(`kernel
(list (xref-make str (xref-make-bogus-location
"Defined in #%%kernel -- source not available")))))))
@@ -1008,32 +1134,31 @@ and `racket-repl-documentation'."
"View documentation in an external web browser.
The command varies based on how many \\[universal-argument] command prefixes you supply.
+\\<racket-repl-mode-map>
-1. None.
-
- Uses the symbol at point. Tries to find documentation for an
- identifer defined in the current namespace.
+- \\[racket-repl-documentation]
- If no such identifer exists, opens the Search Manuals page. In
- this case, the variable `racket-documentation-search-location'
- determines whether the search is done locally as with `raco
- doc`, or visits a URL.
+ Uses the symbol at point. Tries to find documentation for an
+ identifer defined in the current namespace.
-2. \\[universal-argument]
+ If no such identifer exists, opens the Search Manuals page. In
+ this case, the variable `racket-documentation-search-location'
+ determines whether the search is done locally as with `raco
+ doc`, or visits a URL.
- Prompts you to enter a symbol, defaulting to the symbol at
- point if any.
+- \\[universal-argument] \\[racket-repl-documentation]
- Otherwise behaves like 1.
+ Prompts you to enter a symbol, defaulting to the symbol at
+ point if any.
-3. \\[universal-argument] \\[universal-argument]
+- \\[universal-argument] \\[universal-argument] \\[racket-repl-documentation]
- Prompts you to enter anything, defaulting to the symbol at
- point if any.
+ Prompts you to enter anything, defaulting to the symbol at
+ point if any.
- Proceeds directly to the Search Manuals page. Use this if you
- would like to see documentation for all identifiers named
- \"define\", for example."
+ Proceeds directly to the Search Manuals page. Use this if you
+ would like to see documentation for all identifiers named
+ \"define\", for example."
(interactive "P")
(racket--doc prefix 'namespace racket--repl-namespace-symbols))
@@ -1041,8 +1166,13 @@ The command varies based on how many \\[universal-argument] command prefixes you
(defconst racket--compilation-error-regexp-alist
(list
- ;; Any apparent file:line[:.]col
- (list (rx (group-n 1 (+? (not (syntax whitespace))))
+ ;; 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 ?\: ?\.)
@@ -1062,7 +1192,10 @@ The command varies based on how many \\[universal-argument] command prefixes you
#'racket--adjust-group-1 2 3 0 1)
;; Any htdp check-expect failure message
(list (rx "In "
- (group-n 1 (+? (not (syntax whitespace))))
+ (group-n 1
+ (+ (not (any " \r\n")))
+ ?.
+ (+ (not (any " \r\n"))))
" at line "
(group-n 2 (+ digit))
" column "
@@ -1071,7 +1204,11 @@ The command varies based on how many \\[universal-argument] command prefixes you
"Our value for the variable `compilation-error-regexp-alist'.")
(defun racket--adjust-group-1 ()
- (list (funcall racket-path-from-racket-to-emacs-function (match-string 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
@@ -1092,6 +1229,7 @@ The command varies based on how many \\[universal-argument] command prefixes you
("M-C-y" racket-insert-lambda)
("C-c C-d" racket-repl-documentation)
("C-c C-." racket-repl-describe)
+ ("C-c C-s" racket-describe-search)
("C-c C-z" racket-repl-switch-to-edit)
("C-c C-l" racket-logger)
("C-c C-c" racket-repl-break)
@@ -1187,7 +1325,7 @@ want the REPL buffer to be cleared before each run, much like
with Dr Racket. To do so you can use `customize', or, add to your
Emacs init file something like:
- (add-hook 'racket-before-run-hook #'racket-repl-clear)
+ (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
diff --git a/racket-scribble.el b/racket-scribble.el
new file mode 100644
index 0000000..363af6c
--- /dev/null
+++ b/racket-scribble.el
@@ -0,0 +1,548 @@
+;;; racket-scribble.el -*- lexical-binding: t -*-
+
+;; Copyright (c) 2021-2022 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 'seq)
+(require 'shr)
+(require 'subr-x)
+(require 'url-util)
+(require 'tramp)
+
+(defconst racket--scribble-temp-nbsp #x2020
+ "Character we substitute for #xA0 non-breaking-space.
+
+We do this because HTML rendered by Scribble relies heavily on
+tables and for layout. But `shr-insert-document' treats nbsp
+aka #xA0 as a plain, breaking space, and furthermore deletes
+leading spaces in <td> elements.
+
+After doing a `shr-insert-document' you need to replace this in
+the buffer with a plain space, e.g.
+
+ (goto-char (point-min))
+ (while (re-search-forward (string racket--scribble-temp-nbsp) nil t)
+ (replace-match \" \" t t))
+
+This will ensure that the non-breaking-space chars actually have
+the effect of being non-breaking.")
+
+(defun racket--scribble-path->shr-dom (path)
+ (with-temp-message (format "Getting and formatting documentation %s..."
+ path)
+ (let* ((tramp-verbose 2) ;avoid excessive messages
+ (base (file-name-directory path))
+ (dom (racket--html-file->dom path))
+ (body (racket--scribble-body dom))
+ (body (racket--massage-scribble-dom path base body)))
+ `(html ()
+ (head () (base ((href . ,base))))
+ ,body))))
+
+(defun racket--html-file->dom (path)
+ (with-temp-buffer
+ (insert-file-contents-literally path)
+ (libxml-parse-html-region (point-min) (point-max))))
+
+(defun racket--scribble-body (dom)
+ "Return a body with the interesting elements in DOM.
+
+With a normal Racket documentation page produced by Scribble,
+these are only elements from the maincolumn/main div -- not the
+tocset sibling.
+
+With other doc pages, e.g. from r5rs, these are simply all the
+body elements."
+ (pcase (seq-some (lambda (v)
+ (pcase v (`(body . ,_) v)))
+ dom)
+ (`(body ,_
+ (div ((class . "tocset")) . ,_)
+ (div ((class . "maincolumn"))
+ (div ((class . "main")) . ,xs))
+ . ,_)
+ `(body () ,@xs))
+ (body body)))
+
+;; Dynamically bound (like Racket parameters).
+(defvar racket--scribble-file nil)
+(defvar racket--scribble-base nil)
+
+(defun racket--massage-scribble-dom (file base dom)
+ "Simplify the HTML so that `shr-insert-document' renders better.
+
+In some cases we resort to returning custom elements for
+`racket-describe' to handle specially."
+ (let ((racket--scribble-file file)
+ (racket--scribble-base base))
+ (save-match-data
+ (racket--walk-dom dom))))
+
+(defun racket--walk-dom (dom)
+ (pcase dom
+ ;; Page navigation. Obtain from suitable navsettop. Ignore others.
+ (`(div ((class . "navsettop"))
+ (span ((class . "navleft"))
+ (form . ,_)
+ ,_
+ (a ((href . ,top) . ,_) . ,_)
+ . ,_)
+ (span ((class . "navright"))
+ ,_
+ ,(or `(a ((href . ,prev) . ,_) . ,_)
+ (app ignore prev))
+ ,_
+ (a ((href . ,up) . ,_) . ,_)
+ ,_
+ ,(or `(a ((href . ,next) . ,_) . ,_)
+ (app ignore next)))
+ . ,_)
+ `(racket-nav ((top . ,(expand-file-name top racket--scribble-base))
+ (prev . ,(and prev (expand-file-name prev racket--scribble-base)))
+ (up . ,(expand-file-name up racket--scribble-base))
+ (next . ,(and next (expand-file-name next racket--scribble-base))))))
+ (`(div ((class . ,"navsettop")) . ,_)
+ `(span))
+ (`(div ((class . ,"navsetbottom")) . ,_)
+ `(span))
+
+ ;; The kind (e.g. procedure or syntax): Add <hr>
+ (`(div ((class . "RBackgroundLabel SIEHidden"))
+ (div ((class . "RBackgroundLabelInner"))
+ (p () . ,xs)))
+ `(div ()
+ (hr)
+ (span ((class . "RktCmt"))
+ ,@(mapcar #'racket--walk-dom xs))))
+
+ ;; Change SIntrapara div to p, which helps shr supply sufficient
+ ;; line-breaks.
+ (`(div ((class . "SIntrapara")) . ,xs)
+ `(p () ,@(mapcar #'racket--walk-dom xs)))
+
+ ;; RktValDef|RktStxDef is the name of the thing in the bluebox.
+ ;; This is likely also nested in a (span ([class "RktSym"])), so
+ ;; we'll get that face as well, but unlinkfy preserving the class
+ ;; for `racket-render-tag-span'.
+ ((and `(a ,as . ,xs)
+ (guard (member (dom-attr dom 'class) '("RktValDef RktValLink"
+ "RktStxDef RktStxLink"))))
+ `(span ,as ,@(mapcar #'racket--walk-dom xs)))
+
+ ;; Hack: Handle tables of class "RktBlk" whose tr's contain only a
+ ;; single td --- which, weirdly, Scribble uses for code blocks
+ ;; like "Examples" --- by "un-table-izing" them to simple divs.
+ ;; This is to prevent shr from trying too hard to handle table
+ ;; widths and indent but just messing it up for code blocks (e.g.
+ ;; the first and second lines will be indented too much).
+ ((and `(table ,_ . ,rows)
+ (guard (equal (dom-attr dom 'class) "RktBlk")))
+ `(div ()
+ ,@(mapcar
+ (pcase-lambda (`(tr ,_ (td ,_ . ,xs)))
+ ;; Unwrap Rkt{Res Out Err} in a <p> that causes excess
+ ;; line breaks.
+ (let ((xs (pcase xs
+ (`((p ,_ . ,xs)) xs)
+ (xs xs))))
+ `(div () ,@(mapcar #'racket--walk-dom xs))))
+ rows)))
+
+ ;; Hack: Ensure blank line after defmodule blocks
+ ((and `(table ,_ . ,xs)
+ (guard (equal (dom-attr dom 'class) "defmodule")))
+ `(div ()
+ (table () ,@(mapcar #'racket--walk-dom xs))
+ (p ())))
+
+ ;; Replace some <a> with <racket-anchor> because shr in Emacs 25.2
+ ;; doesn't seem to handle these well.
+ (`(a ((name . ,name)) . ,xs)
+ `(racket-anchor ((name . ,name)) . ,xs))
+
+ ;; Replace <a> with <racket-doc-link> or <racket-ext-link>. The
+ ;; former are links to follow using racket-describe-mode, the
+ ;; latter using browse-url (a general-purpose, probably external
+ ;; web browser).
+ (`(a ,_ . ,xs)
+ (pcase (dom-attr dom 'href)
+ ;; Handle "local-redirect" links. Scribble writes these as
+ ;; external links, and generates doc/local-redirect.js to
+ ;; adjust these on page load. Partially mimic that js here.
+ ((and href
+ (or
+ (pred
+ (string-match ;as for installed releases
+ "^https?://download.racket-lang.org/releases/[^/]+/doc/local-redirect/index.html[?]\\(.*\\)$"))
+ (pred
+ (string-match ;as for local builds from source
+ "^https?://docs.racket-lang.org/local-redirect/index.html[?]\\(.*\\)$"))
+ (pred
+ (string-match ;as for installed snapshot builds
+ "^https?://.+?/snapshots/[^/]+/doc/local-redirect/index.html[?]\\(.*\\)$"))))
+ (let ((qps (url-parse-query-string (match-string 1 href))))
+ (if (assoc "tag" qps)
+ `(span () ,@(mapcar #'racket--walk-dom xs)) ;don't handle
+ ;; Assume local-redirect.js has a "boring" link_dirs where
+ ;; the second element of each sub-array is simply the
+ ;; first one with "../" prepended. We can simply use the
+ ;; value of the `doc` query parameter with "../"
+ ;; prepended.
+ (let* ((doc (cadr (assoc "doc" qps)))
+ (rel (cadr (assoc "rel" qps)))
+ (rel-path (concat "../" doc "/" rel))
+ (abs-path (expand-file-name rel-path racket--scribble-base)))
+ ;; recur to do our usual path/anchor processing for
+ ;; local hrefs
+ (racket--walk-dom
+ `(a ((href . ,abs-path)
+ (class . ,(dom-attr dom 'class)))
+ ,@xs))))))
+ ;; Some other, truly external links
+ ((and href (pred (string-match-p "^https?://")))
+ `(racket-ext-link ((href . ,href)
+ (class . ,(dom-attr dom 'class)))
+ ,@(mapcar #'racket--walk-dom xs)))
+ ((and href (pred (string-match-p "^mailto:")))
+ `(racket-ext-link ((href . ,href)
+ (class . ,(dom-attr dom 'class)))
+ ,@(mapcar #'racket--walk-dom xs)))
+ ;; Lazy hack to remove the "go to specific" links on the top
+ ;; doc/index.html page. FIXME: Instead remove entire paragraph?
+ ((pred (string-match-p "#$"))
+ `(span))
+ ;; Otherwise the common case is some combo of path and/or anchor.
+ (href
+ (pcase-let* ((`(,path . ,anchor)
+ (save-match-data
+ (cond
+ ((equal href "")
+ (cons racket--scribble-file nil))
+ ((string-match "^#\\(.+\\)$" href)
+ (cons racket--scribble-file (match-string 1 href)))
+ ((string-match "^\\(.*\\)#\\(.+\\)$" href)
+ (cons (expand-file-name (match-string 1 href)
+ racket--scribble-base)
+ (match-string 2 href)))
+ ((string-match "^\\(.+\\)$" href)
+ (cons (expand-file-name (match-string 1 href)
+ racket--scribble-base)
+ nil))
+ (t (error "unexpected href")))))
+ (anchor (and anchor (url-unhex-string anchor))))
+ `(racket-doc-link ((path . ,path)
+ (anchor . ,anchor)
+ (class . ,(dom-attr dom 'class)))
+ ,@(mapcar #'racket--walk-dom xs))))))
+
+ ;; For some reason scribble renders this, which shr doesn't
+ ;; handle, instead of <i>, which it does.
+ (`(span ((style . "font-style: italic")) . ,xs)
+ `(i () ,@(mapcar #'racket--walk-dom xs)))
+
+ ;; Delete some things that produce unwanted blank lines and/or
+ ;; indents.
+ (`(blockquote ((class . ,(or "SVInsetFlow" "SubFlow"))) . ,xs)
+ `(span () ,@(mapcar #'racket--walk-dom xs)))
+ (`(p ((class . "RForeground")) . ,xs)
+ `(div () ,@(mapcar #'racket--walk-dom xs)))
+
+ ;; Images in refpara blocks; remove
+ (`(img ((src . ,(or "finger.png" "magnify.png")) . ,_))
+ `(span))
+
+ ;; Images generally: Convert src to data: uri scheme. "inline".
+ ;; (Otherwise shr would try to `url-queue-retrieve' these.)
+ (`(img ,as)
+ `(img ,(cons (cons 'src
+ (racket--scribble-file->data-uri
+ (expand-file-name (dom-attr dom 'src)
+ racket--scribble-base)))
+ (assq-delete-all 'src as))))
+
+ ;; Otherwise generic HTML
+ (`(,tag ,as . ,xs)
+ `(,tag ,as ,@(mapcar #'racket--walk-dom xs)))
+ ((and (pred stringp) s)
+ (subst-char-in-string #xA0 racket--scribble-temp-nbsp s))
+ ((and (pred numberp) n) (string n))
+ (`() "")
+ (sym (racket--html-char-entity-symbol->string sym))))
+
+(defun racket--scribble-file->data-uri (image-file-name)
+ (concat
+ "data:image/png;base64,"
+ (with-temp-buffer
+ (insert-file-contents-literally image-file-name)
+ (base64-encode-region (point-min) (point-max) t)
+ (buffer-string))))
+
+(defconst racket--html-char-entities
+ `((quot . 34)
+ (amp . 38)
+ (apos . 39)
+ (lt . 60)
+ (gt . 62)
+ (nbsp . ,racket--scribble-temp-nbsp)
+ (iexcl . 161)
+ (cent . 162)
+ (pound . 163)
+ (curren . 164)
+ (yen . 165)
+ (brvbar . 166)
+ (sect . 167)
+ (uml . 168)
+ (copy . 169)
+ (ordf . 170)
+ (laquo . 171)
+ (not . 172)
+ (shy . 173)
+ (reg . 174)
+ (macr . 175)
+ (deg . 176)
+ (plusmn . 177)
+ (sup2 . 178)
+ (sup3 . 179)
+ (acute . 180)
+ (micro . 181)
+ (para . 182)
+ (middot . 183)
+ (cedil . 184)
+ (sup1 . 185)
+ (ordm . 186)
+ (raquo . 187)
+ (frac14 . 188)
+ (frac12 . 189)
+ (frac34 . 190)
+ (iquest . 191)
+ (Agrave . 192)
+ (Aacute . 193)
+ (Acirc . 194)
+ (Atilde . 195)
+ (Auml . 196)
+ (Aring . 197)
+ (AElig . 198)
+ (Ccedil . 199)
+ (Egrave . 200)
+ (Eacute . 201)
+ (Ecirc . 202)
+ (Euml . 203)
+ (Igrave . 204)
+ (Iacute . 205)
+ (Icirc . 206)
+ (Iuml . 207)
+ (ETH . 208)
+ (Ntilde . 209)
+ (Ograve . 210)
+ (Oacute . 211)
+ (Ocirc . 212)
+ (Otilde . 213)
+ (Ouml . 214)
+ (times . 215)
+ (Oslash . 216)
+ (Ugrave . 217)
+ (Uacute . 218)
+ (Ucirc . 219)
+ (Uuml . 220)
+ (Yacute . 221)
+ (THORN . 222)
+ (szlig . 223)
+ (agrave . 224)
+ (aacute . 225)
+ (acirc . 226)
+ (atilde . 227)
+ (auml . 228)
+ (aring . 229)
+ (aelig . 230)
+ (ccedil . 231)
+ (egrave . 232)
+ (eacute . 233)
+ (ecirc . 234)
+ (euml . 235)
+ (igrave . 236)
+ (iacute . 237)
+ (icirc . 238)
+ (iuml . 239)
+ (eth . 240)
+ (ntilde . 241)
+ (ograve . 242)
+ (oacute . 243)
+ (ocirc . 244)
+ (otilde . 245)
+ (ouml . 246)
+ (divide . 247)
+ (oslash . 248)
+ (ugrave . 249)
+ (uacute . 250)
+ (ucirc . 251)
+ (uuml . 252)
+ (yacute . 253)
+ (thorn . 254)
+ (yuml . 255)
+ (OElig . 338)
+ (oelig . 339)
+ (Scaron . 352)
+ (scaron . 353)
+ (Yuml . 376)
+ (fnof . 402)
+ (circ . 710)
+ (tilde . 732)
+ (Alpha . 913)
+ (Beta . 914)
+ (Gamma . 915)
+ (Delta . 916)
+ (Epsilon . 917)
+ (Zeta . 918)
+ (Eta . 919)
+ (Theta . 920)
+ (Iota . 921)
+ (Kappa . 922)
+ (Lambda . 923)
+ (Mu . 924)
+ (Nu . 925)
+ (Xi . 926)
+ (Omicron . 927)
+ (Pi . 928)
+ (Rho . 929)
+ (Sigma . 931)
+ (Tau . 932)
+ (Upsilon . 933)
+ (Phi . 934)
+ (Chi . 935)
+ (Psi . 936)
+ (Omega . 937)
+ (alpha . 945)
+ (beta . 946)
+ (gamma . 947)
+ (delta . 948)
+ (epsilon . 949)
+ (zeta . 950)
+ (eta . 951)
+ (theta . 952)
+ (iota . 953)
+ (kappa . 954)
+ (lambda . 955)
+ (mu . 956)
+ (nu . 957)
+ (xi . 958)
+ (omicron . 959)
+ (pi . 960)
+ (rho . 961)
+ (sigmaf . 962)
+ (sigma . 963)
+ (tau . 964)
+ (upsilon . 965)
+ (phi . 966)
+ (chi . 967)
+ (psi . 968)
+ (omega . 969)
+ (thetasym . 977)
+ (upsih . 978)
+ (piv . 982)
+ (ensp . 8194)
+ (emsp . 8195)
+ (thinsp . 8201)
+ (zwnj . 8204)
+ (zwj . 8205)
+ (lrm . 8206)
+ (rlm . 8207)
+ (ndash . 8211)
+ (mdash . 8212)
+ (lsquo . 8216)
+ (rsquo . 8217)
+ (sbquo . 8218)
+ (ldquo . 8220)
+ (rdquo . 8221)
+ (bdquo . 8222)
+ (dagger . 8224)
+ (Dagger . 8225)
+ (bull . 8226)
+ (hellip . 8230)
+ (permil . 8240)
+ (prime . 8242)
+ (Prime . 8243)
+ (lsaquo . 8249)
+ (rsaquo . 8250)
+ (oline . 8254)
+ (frasl . 8260)
+ (euro . 8364)
+ (image . 8465)
+ (weierp . 8472)
+ (real . 8476)
+ (trade . 8482)
+ (alefsym . 8501)
+ (larr . 8592)
+ (uarr . 8593)
+ (rarr . 8594)
+ (darr . 8595)
+ (harr . 8596)
+ (crarr . 8629)
+ (lArr . 8656)
+ (uArr . 8657)
+ (rArr . 8658)
+ (dArr . 8659)
+ (hArr . 8660)
+ (forall . 8704)
+ (part . 8706)
+ (exist . 8707)
+ (empty . 8709)
+ (nabla . 8711)
+ (isin . 8712)
+ (notin . 8713)
+ (ni . 8715)
+ (prod . 8719)
+ (sum . 8721)
+ (minus . 8722)
+ (lowast . 8727)
+ (radic . 8730)
+ (prop . 8733)
+ (infin . 8734)
+ (ang . 8736)
+ (and . 8743)
+ (or . 8744)
+ (cap . 8745)
+ (cup . 8746)
+ (int . 8747)
+ (there4 . 8756)
+ (sim . 8764)
+ (cong . 8773)
+ (asymp . 8776)
+ (ne . 8800)
+ (equiv . 8801)
+ (le . 8804)
+ (ge . 8805)
+ (sub . 8834)
+ (sup . 8835)
+ (nsub . 8836)
+ (sube . 8838)
+ (supe . 8839)
+ (oplus . 8853)
+ (otimes . 8855)
+ (perp . 8869)
+ (sdot . 8901)
+ (lceil . 8968)
+ (rceil . 8969)
+ (lfloor . 8970)
+ (rfloor . 8971)
+ (lang . 9001)
+ (rang . 9002)
+ (loz . 9674)
+ (spades . 9824)
+ (clubs . 9827)
+ (hearts . 9829)
+ (diams . 9830)))
+
+(defun racket--html-char-entity-symbol->string (sym)
+ "HTML entity symbols to strings.
+From <https://github.com/GNOME/libxml2/blob/master/HTMLparser.c>."
+ (string (or (cdr (assq sym racket--html-char-entities))
+ ??)))
+
+(provide 'racket-scribble)
+
+;; racket-scribble.el ends here
diff --git a/racket-shell.el b/racket-shell.el
new file mode 100644
index 0000000..711a232
--- /dev/null
+++ b/racket-shell.el
@@ -0,0 +1,89 @@
+;;; racket-shell.el -*- lexical-binding: t -*-
+
+;; Copyright (c) 2022 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 'racket-custom)
+(require 'racket-util)
+(require 'shell)
+(require 'term)
+
+(defun racket-racket ()
+ "Use command-line racket to run the file.
+
+Uses a shell or terminal buffer as specified by the configuration
+variable `racket-shell-or-terminal-function'."
+ (interactive)
+ (racket--shell-or-terminal
+ (concat (shell-quote-argument (racket--buffer-file-name)))))
+
+(defun racket-raco-test ()
+ "Use command-line raco test to run the \"test\" submodule.
+
+Uses a shell or terminal buffer as specified by the configuration
+variable `racket-shell-or-terminal-function'."
+ (interactive)
+ (racket--shell-or-terminal
+ (concat "-l raco test -x "
+ (shell-quote-argument (racket--buffer-file-name)))))
+
+(defun racket--shell-or-terminal (args)
+ (racket--save-if-changed)
+ (let* ((exe (shell-quote-argument
+ (if (file-name-absolute-p racket-program)
+ (expand-file-name racket-program) ;handle e.g. ~/
+ racket-program)))
+ (cmd (concat exe " " args))
+ (win (selected-window)))
+ (funcall racket-shell-or-terminal-function cmd)
+ (select-window win)))
+
+(defun racket-shell (cmd)
+ "Run CMD using `shell'.
+
+A value for the variable `racket-shell-or-terminal-function'."
+ (let ((buf (shell)))
+ (comint-simple-send buf cmd)))
+
+(defun racket-term (cmd)
+ "Run CMD using `term'.
+
+A value for the variable `racket-shell-or-terminal-function'."
+ (let ((buf (term (or explicit-shell-file-name
+ (getenv "ESHELL")
+ (getenv "SHELL")
+ "/bin/sh"))))
+ (term-simple-send buf cmd)))
+
+(defun racket-ansi-term (cmd)
+ "Run CMD using `ansi-term'.
+
+A value for the variable `racket-shell-or-terminal-function'."
+ (let ((buf (ansi-term (or explicit-shell-file-name
+ (getenv "ESHELL")
+ (getenv "SHELL")
+ "/bin/sh"))))
+ (term-simple-send buf cmd)))
+
+(declare-function vterm "ext:vterm")
+(declare-function vterm-send-return "ext:vterm")
+(declare-function vterm-send-string "ext:vterm")
+
+(defun racket-vterm (cmd)
+ "Run CMD using `vterm', if that package is installed.
+
+A value for the variable `racket-shell-or-terminal-function'."
+ (unless (require 'vterm nil 'noerror)
+ (error "Package 'vterm' is not available"))
+ (vterm)
+ (vterm-send-string cmd)
+ (vterm-send-return))
+
+(provide 'racket-shell)
+
+;; racket-shell.el ends here
diff --git a/racket-show.el b/racket-show.el
index 4f4bba5..35ec107 100644
--- a/racket-show.el
+++ b/racket-show.el
@@ -1,41 +1,59 @@
;;; racket-show.el -*- lexical-binding: t -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-util)
(require 'racket-custom)
-(require 'pos-tip)
+(require 'pos-tip nil t) ;noerror
(require 'cl-macs)
-
-(defun racket-show (val &optional pos)
- "See the variable `racket-show-functions' for information about VAL and POS."
- (dolist (f racket-show-functions)
- (funcall f val pos)))
-
-(defun racket-show-echo-area (v &optional _pos)
+(require 'face-remap)
+
+(defun racket-show (str &optional pos transient-p)
+ "Apply STR and POS to functions in the variable `racket-show-functions'.
+
+See that for meaning of STR and POS.
+
+When TRANSIENT-P, we automatically hide before the next command
+runs. Otherwise, the UI might remain visible indefinitely --
+depending on how a racket-show function displays --- until a
+subsequent call to `racket-show' to hide or to show a new value.
+Either behavior could be desirable depending on the caller's use
+case. For example `racket-xp-mode' wants the display to remain
+visible, if possible, even when the user chooses a command to
+select another window; only point motion hides or shows a
+different annotation."
+ (unless (string-or-null-p str)
+ (signal 'wrong-type-argument `(string-or-null-p ,str)))
+ (when (racket--non-empty-string-p str)
+ (unless (number-or-marker-p pos)
+ (signal 'wrong-type-argument `(number-or-marker-p ,pos))))
+ (run-hook-with-args 'racket-show-functions str pos)
+ (if transient-p
+ (add-hook 'pre-command-hook #'racket-show--pre-command-hook nil t)
+ (remove-hook 'pre-command-hook #'racket-show--pre-command-hook t)))
+
+(defun racket-show--pre-command-hook ()
+ "Hide and remove ourselves as a pre-command-hook."
+ (run-hook-with-args 'racket-show-functions "" nil)
+ (remove-hook 'pre-command-hook #'racket-show--pre-command-hook t))
+
+(defun racket-show-echo-area (str &optional _pos)
"Show things in the echo area.
-A value for the variable `racket-show-functions'."
- (let ((message-log-max nil))
- (if v
- (message "%s" v)
- (message ""))))
+A value for the variable `racket-show-functions'.
+
+This does /not/ add STR to the \"*Messages*\" log buffer."
+ (when str
+ (let ((message-log-max nil)) ;don't log
+ (message "%s" str))))
-(defun racket-show-header-line (v &optional _pos)
+(defun racket-show-header-line (str &optional _pos)
"Show things using a buffer header line.
A value for the variable `racket-show-functions'.
@@ -45,31 +63,30 @@ way, the buffer below doesn't \"jump up and down\" by a line as
messages appear and disappear. Only when V is nil do we remove
the header line."
(setq-local header-line-format
- (and v (format "%s" (racket--only-first-line v)))))
+ (and str
+ (format "%s" (racket--only-first-line str)))))
(defun racket--only-first-line (str)
(save-match-data
(string-match (rx (group (* (not (any ?\n))))) str)
(match-string 1 str)))
-(defun racket-show-pos-tip (v &optional pos)
+(defun racket-show-pos-tip (str &optional pos)
"Show things using `pos-tip-show' if available.
A value for the variable `racket-show-functions'."
- (when (racket--pos-tip-available-p)
- (if (racket--non-empty-string-p v)
- (pos-tip-show v nil pos)
+ (when (and (fboundp 'x-hide-tip)
+ (fboundp 'x-show-tip)
+ (not (memq window-system (list nil 'pc)))
+ (fboundp 'pos-tip-show)
+ (fboundp 'pos-tip-hide))
+ (if (racket--non-empty-string-p str)
+ (pos-tip-show str nil pos)
(pos-tip-hide))))
-(defun racket--pos-tip-available-p ()
- "Is `pos-tip' available and expected to work on current frame?"
- (and (fboundp 'x-hide-tip)
- (fboundp 'x-show-tip)
- (not (memq window-system (list nil 'pc)))))
-
(defvar-local racket--pseudo-tooltip-overlays nil)
-(defun racket-show-pseudo-tooltip (v &optional pos)
+(defun racket-show-pseudo-tooltip (str &optional pos)
"Show using an overlay that resembles a tooltip.
This is nicer than `racket-show-pos-tip' because it:
@@ -79,12 +96,13 @@ This is nicer than `racket-show-pos-tip' because it:
- Performs well when `x-gtk-use-system-tooltips' is nil.
On the other hand, this does not look as nice when displaying
-text that spans multiple lines. In that case, we simply
-left-justify everything and do not draw any border."
+text that spans multiple lines or is too wide to fit the window.
+In that case, we simply left-justify everything and do not draw
+any border."
(racket--delete-pseudo-tooltip-overlays)
- (when (racket--non-empty-string-p v)
+ (when (racket--non-empty-string-p str)
(setq-local racket--pseudo-tooltip-overlays
- (racket--make-pseudo-tooltip-overlays v pos))))
+ (racket--make-pseudo-tooltip-overlays str pos))))
(defun racket--delete-pseudo-tooltip-overlays ()
(dolist (ov racket--pseudo-tooltip-overlays)
@@ -93,87 +111,115 @@ left-justify everything and do not draw any border."
(defun racket--make-pseudo-tooltip-overlays (text pos)
"Create one or more overlays for a pseudo tooltip, returning them in a list."
- (if (string-match-p "\n" text)
- ;; When text is multi-line, we don't try to simulate a tooltip,
- ;; exactly. Instead we simply "insert" the multiple lines left
+ (if (or (string-match-p "\n" text)
+ (< (window-width) (+ (string-width text) 2))
+ (and text-scale-mode (< 0 text-scale-mode-amount)))
+ ;; When text is multi-line or too wide, we don't try to simulate
+ ;; a tooltip, exactly. Instead we simply "insert" left
;; justified, before the next line.
(let* ((text (propertize (concat text "\n")
'face
`(:inherit default
:foreground ,(face-foreground 'tooltip)
:background ,(face-background 'tooltip))))
- (eol (save-excursion (goto-char pos) (point-at-eol)))
+ (eol (racket--eol pos))
(ov (make-overlay eol (1+ eol))))
(overlay-put ov 'after-string text)
(list ov))
- ;; Otherwise we simulate a tooltip displayed one line below pos,
- ;; and one column right (although it might start further left
- ;; depending on window-width) "over" any existing text.
- (pcase-let*
- ((text (propertize (concat " " text " ")
- 'face
- `(:inherit default
- :foreground ,(face-foreground 'tooltip)
- :background ,(face-background 'tooltip)
- :box (:line-width -1))))
- (text-len (length text))
- (bol (save-excursion (goto-char pos) (point-at-bol)))
- (eol (save-excursion (goto-char pos) (point-at-eol)))
- ;; Position the tooltip on the next line, indented to `pos'
- ;; -- but not so far it ends off right edge.
- (indent (max 0 (min (- pos bol)
- (- (window-width) text-len))))
- (beg (+ eol indent 1))
- (next-eol (save-excursion (goto-char (1+ eol)) (point-at-eol))))
- ;; If the tip starts before next-eol, create an overlay with the
- ;; 'display property, covering the span of the tooltip text but
- ;; not beyond next-eol.
- ;;
- ;; As a further wrinkle, when the overlay does not cover the
- ;; entire rest of the line, our new text might not be exactly
- ;; the same pixel width as the text we replace -- causing the
- ;; remaining text to shift. This can happen e.g. due to Unicode
- ;; characters like λ. Furthermore, our replacement text can be
- ;; two pixels wider because :box (:line-width -1) doesn't seem
- ;; to work as advertised.
- ;;
- ;; To avoid this, we add _another_ overlay simply to replace the
- ;; character following our tooltip with a space of the necessary
- ;; pixel width to keep things aligned. Although covering the
- ;; character with a space isn't great -- even if you justify it
- ;; as a sort of "shadow" (?) -- it's better than having the
- ;; remainder of the line jiggle as the tooltip apears and
- ;; disappears.
- (if (< beg next-eol)
- (cl-labels ((text-pixel-width
- (beg end)
- (car (window-text-pixel-size nil beg end))))
- (let* ((end (min next-eol (+ beg text-len)))
- (ov (make-overlay beg end))
- (old (text-pixel-width (1+ eol) end))
- (_ (overlay-put ov 'display text))
- (new (text-pixel-width (1+ eol) end))
- (diff (- new old)))
- (cons
- ov
- (when (and (not (zerop diff))
- (< end next-eol))
- (let* ((ov-spacer (make-overlay end (1+ end)))
- (width (text-pixel-width end (1+ end)))
- (space-width (abs (- width diff))))
- (overlay-put ov-spacer
- 'display
- `(space
- :width (,space-width)))
- (list ov-spacer))))))
- ;; Else the tip starts after next-eol. So, create an overlay
- ;; on the newline, and use an after-string, where we prefix
- ;; enough blank spaces before the tooltip text itself to get
- ;; the desired indent.
- (let* ((ov (make-overlay (1- next-eol) next-eol))
- (blanks (make-string (- beg next-eol) 32)))
- (overlay-put ov 'after-string (concat blanks text))
- (list ov))))))
+ ;; Else we simulate a tooltip. The only question is where, and the
+ ;; overlay(s) necessary to achieve that.
+ (let*
+ ((text (propertize (concat " " text " ")
+ 'face
+ `(:inherit default
+ :foreground ,(face-foreground 'tooltip)
+ :background ,(face-background 'tooltip)
+ :box (:line-width -1))))
+ (text-width (string-width text))
+ (bol (racket--bol pos))
+ (eol (racket--eol pos)))
+ ;; If there is room after end of same line, show there.
+ (if (< (+ text-width 1) (- (window-width) (- eol bol)))
+ (let ((ov (make-overlay (1- eol) eol)))
+ (overlay-put ov 'after-string (concat " " text))
+ (list ov))
+ ;; Otherwise we simulate a tooltip displayed one line below
+ ;; pos, and one column right (although it might start further
+ ;; left depending on window-width) "over" any existing text.
+ (let*
+ (;; Position the tooltip on the next line, indented to `pos'
+ ;; -- but not so far it ends off right edge.
+ (indent (max 0 (min (- pos bol)
+ (- (window-width) text-width 2))))
+ (beg (+ eol indent 1))
+ (next-eol (racket--eol (1+ eol))))
+ ;; If the tip starts before next-eol, create an overlay with
+ ;; the 'display property, covering the span of the tooltip
+ ;; text but not beyond next-eol.
+ ;;
+ ;; As a further wrinkle, when the overlay does not cover the
+ ;; entire rest of the line, our new text might not be
+ ;; exactly the same pixel width as the text we replace --
+ ;; causing the remaining text to shift. This can happen e.g.
+ ;; due to Unicode characters like λ. Furthermore, our
+ ;; replacement text can be two pixels wider because :box
+ ;; (:line-width -1) doesn't seem to work as advertised.
+ ;;
+ ;; To avoid this, we add _another_ overlay simply to replace
+ ;; the character following our tooltip with a space of the
+ ;; necessary pixel width to keep things aligned. Although
+ ;; covering the character with a space isn't great -- even
+ ;; if you justify it as a sort of "shadow" (?) -- it's
+ ;; better than having the remainder of the line jiggle as
+ ;; the tooltip apears and disappears.
+ (if (< beg next-eol)
+ (cl-flet ((text-pixel-width
+ (beg end)
+ (car (window-text-pixel-size nil beg end))))
+ (let* ((end (min next-eol (+ beg text-width)))
+ (ov (make-overlay beg end))
+ (old (text-pixel-width (1+ eol) end))
+ (_ (overlay-put ov 'display text))
+ (new (text-pixel-width (1+ eol) end))
+ (diff (- new old)))
+ (cons
+ ov
+ (when (and (not (zerop diff))
+ (< end next-eol))
+ (let* ((ov-spacer (make-overlay end (1+ end)))
+ (width (text-pixel-width end (1+ end)))
+ (space-width (abs (- width diff))))
+ (overlay-put ov-spacer
+ 'display
+ `(space
+ :width (,space-width)))
+ (list ov-spacer))))))
+ ;; Else the tip starts after next-eol. So, create an overlay
+ ;; on the newline, and use an after-string, where we prefix
+ ;; enough blank spaces before the tooltip text itself to get
+ ;; the desired indent.
+ (let* ((ov (make-overlay (1- next-eol) next-eol))
+ (blanks (make-string (- beg next-eol) 32)))
+ (overlay-put ov 'after-string (concat blanks text))
+ (list ov))))))))
+
+(defun racket--bol (pos)
+ "Given POS return line beginning position."
+ (save-excursion
+ (goto-char pos)
+ (if visual-line-mode
+ (beginning-of-visual-line)
+ (beginning-of-line))
+ (point)))
+
+(defun racket--eol (pos)
+ "Given POS return line ending position."
+ (save-excursion
+ (goto-char pos)
+ (if visual-line-mode
+ (end-of-visual-line)
+ (end-of-line))
+ (point)))
(provide 'racket-show)
diff --git a/racket-smart-open.el b/racket-smart-open.el
index e4359b2..e2a2015 100644
--- a/racket-smart-open.el
+++ b/racket-smart-open.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;;; racket-smart-open-bracket-mode
@@ -127,6 +119,7 @@ the variable `minor-mode-map-alist'."
"for/first"
"for/last"
"for/fold"
+ "for/foldr"
"for/flvector"
"for/extflvector"
"for/set"
@@ -144,6 +137,7 @@ the variable `minor-mode-map-alist'."
"for*/first"
"for*/last"
"for*/fold"
+ "for*/foldr"
"for*/flvector"
"for*/extflvector"
"for*/set"
@@ -180,7 +174,9 @@ the variable `minor-mode-map-alist'."
;;
;; Note: Previous item handles the first, accumulators subform.
(0 2 ,(rx (seq (or "for/fold"
- "for*/fold")
+ "for*/fold"
+ "for/foldr"
+ "for*/foldr")
(or space line-end))))
;; named-let bindings
;;
@@ -231,9 +227,9 @@ See `racket-smart-open-bracket-mode'."
(eval-after-load 'paredit
'(progn
- (declare-function paredit-open-round 'paredit)
- (declare-function paredit-open-square 'paredit)
- (declare-function paredit-open-curly 'paredit)
+ (declare-function paredit-open-round "paredit" (&optional N) t)
+ (declare-function paredit-open-square "paredit" (&optional N) t)
+ (declare-function paredit-open-curly "paredit" (&optional N) t)
(defun racket--paredit-aware-open (prefix ch)
"A paredit-aware helper for `racket-smart-open-bracket'.
diff --git a/racket-stepper.el b/racket-stepper.el
index 0974fc3..7f4d882 100644
--- a/racket-stepper.el
+++ b/racket-stepper.el
@@ -1,20 +1,12 @@
;;; racket-stepper.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2018-2020 by Greg Hendershott.
+;; Copyright (c) 2018-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'easymenu)
(require 'rx)
@@ -22,6 +14,7 @@
(require 'racket-custom)
(require 'racket-repl)
(require 'racket-util)
+(require 'racket-back-end)
;; Need to define this before racket-stepper-mode
(defvar racket-stepper-mode-map
@@ -61,7 +54,8 @@ Used by the commands `racket-expand-file',
(list racket-stepper-font-lock-keywords
t))) ;keywords only -- not strings/comments
-(defvar racket-stepper--buffer-name "*Racket Stepper*")
+(defun racket--stepper-buffer-name ()
+ (format "*Racket Stepper <%s>*" (racket-back-end-name)))
;;; commands
@@ -130,11 +124,13 @@ Uses Racket's `expand-once` in the namespace from the most recent
(defvar racket--stepper-repl-session-id nil
"The REPL session used when stepping.
-May be nil for 'file stepping, but must be valid for 'expr stepping.")
+
+May be nil for \"file\" stepping, but must be valid for \"expr\"
+stepping.")
(defun racket-stepper--start (which str into-base)
"Ensure buffer and issue initial command.
-WHICH should be 'expr or 'file.
+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)
@@ -144,24 +140,27 @@ INTO-BASE is treated as a raw command prefix arg and converted to boolp."
(eq which 'file))
(error "Only works when the racket-mode buffer has a REPL buffer, and, you should racket-run first"))
;; Create buffer if necessary
- (unless (get-buffer racket-stepper--buffer-name)
- (with-current-buffer (get-buffer-create racket-stepper--buffer-name)
- (racket-stepper-mode)))
- ;; Give it a window if necessary
- (unless (get-buffer-window racket-stepper--buffer-name)
- (pop-to-buffer (get-buffer racket-stepper--buffer-name)))
- ;; Select the stepper window and insert
- (select-window (get-buffer-window racket-stepper--buffer-name))
- (let ((inhibit-read-only t))
- (delete-region (point-min) (point-max))
- (insert "Starting macro expansion stepper... please wait...\n"))
- (racket--cmd/async racket--stepper-repl-session-id
- `(macro-stepper (,which . ,str)
- ,(and into-base t))
- #'racket-stepper--insert))
+ (let ((name (racket--stepper-buffer-name)))
+ (unless (get-buffer name)
+ (with-current-buffer (get-buffer-create name)
+ (racket-stepper-mode)))
+ ;; Give it a window if necessary
+ (unless (get-buffer-window name)
+ (pop-to-buffer (get-buffer name)))
+ ;; Select the stepper window and insert
+ (select-window (get-buffer-window name))
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max))
+ (insert "Starting macro expansion stepper... please wait...\n"))
+ (racket--cmd/async racket--stepper-repl-session-id
+ `(macro-stepper (,which . ,(if (eq which 'file)
+ (racket-file-name-front-to-back str)
+ str))
+ ,(and into-base t))
+ #'racket-stepper--insert)))
(defun racket-stepper--insert (steps)
- (with-current-buffer racket-stepper--buffer-name
+ (with-current-buffer (racket--stepper-buffer-name)
(let ((inhibit-read-only t))
(goto-char (point-max))
(dolist (step steps)
diff --git a/racket-unicode-input-method.el b/racket-unicode-input-method.el
index ac995ec..9086d98 100644
--- a/racket-unicode-input-method.el
+++ b/racket-unicode-input-method.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
;; Following the example of haskell-unicode-input-method.el
@@ -32,8 +24,8 @@ racket-mode and racket-repl-mode buffers, put the following code
in your Emacs init file:
#+BEGIN_SRC elisp
- (add-hook 'racket-mode-hook #'racket-unicode-input-method-enable)
- (add-hook 'racket-repl-mode-hook #'racket-unicode-input-method-enable)
+ (add-hook \\='racket-mode-hook #\\='racket-unicode-input-method-enable)
+ (add-hook \\='racket-repl-mode-hook #\\='racket-unicode-input-method-enable)
#+END_SRC
To temporarily enable this input method for a single buffer you
@@ -60,7 +52,7 @@ input method, you may add code like the following example in your
Emacs init file:
#+BEGIN_SRC elisp
- ;; Either (require 'racket-mode) here, or, if you use
+ ;; Either (require \\='racket-mode) here, or, if you use
;; use-package, put the code below in the :config section.
(with-temp-buffer
(racket-unicode-input-method-enable)
@@ -142,7 +134,7 @@ can turn it off by setting `input-method-highlight-flag' to nil."
("vee " ["∨"])
("wedge " ["∧"])
("follows " ["∘"])
- ("in " ["∈"])
+ ("setin " ["∈"])
("ni " ["∋"])
("notin " ["∉"])
("sqsubset " ["⊏"])
diff --git a/racket-util.el b/racket-util.el
index ee38716..015667e 100644
--- a/racket-util.el
+++ b/racket-util.el
@@ -1,21 +1,14 @@
;;; racket-util.el -*- lexical-binding: t -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+(require 'subr-x)
(require 'racket-custom)
(defun racket--easy-keymap-define (spec)
@@ -41,23 +34,21 @@ DEF is the same as DEF for `define-key'."
spec)
m))
-(defun racket--buffer-file-name (&optional no-adjust)
- "Like `buffer-file-name' but always a non-propertized string.
+(defun racket--buffer-file-name (&optional no-replace-slash)
+ "Like `buffer-file-name' but adjusted for use outside Emacs.
-Unless NO-ADJUST is not nil, applies the name to the function
-variable `racket-path-from-emacs-to-racket-function'."
+Always a non-propertized string.
+
+When on Windows and unless NO-REPLACE-SLASH is not nil, replaces
+back slashes with forward slashes. Emacs uses forward slashes for
+buffer file names even on Windows, so we need to \"reverse\"
+this to use the names with shell programs or a Racket back end."
(let ((v (and (buffer-file-name)
(substring-no-properties (buffer-file-name)))))
- (if no-adjust
- v
- (funcall racket-path-from-emacs-to-racket-function
- v))))
-
-(defun racket--get-buffer-recreate (bufname)
- "Like `get-buffer-create' but re-creates the buffer if it already exists."
- (let ((buf (get-buffer bufname)))
- (when buf (kill-buffer buf)))
- (get-buffer-create bufname))
+ (if (and racket--winp
+ (not no-replace-slash))
+ (subst-char-in-string ?\\ ?/ v)
+ v)))
(defun racket--save-if-changed ()
(unless (eq major-mode 'racket-mode)
@@ -67,8 +58,6 @@ variable `racket-path-from-emacs-to-racket-function'."
(not (file-exists-p (buffer-file-name)))))
(save-buffer)))
-(add-hook 'racket--repl-before-run-hook #'racket--save-if-changed)
-
(defun racket--mode-edits-racket-p ()
"Return non-nil if the current major mode is one that edits Racket code.
@@ -92,34 +81,10 @@ When installed as a package, this can be found from the variable
`load-file-name'. When developing interactively, get it from the
.el buffer file name.")
-(defconst racket--rkt-source-dir
+(defvar racket--rkt-source-dir
(expand-file-name "./racket/" racket--el-source-dir)
"Path to dir of our Racket source files. ")
-;;; trace
-
-(defvar racket--trace-enable nil)
-
-(defun racket--trace (p &optional s retval)
- (when racket--trace-enable
- (let ((b (get-buffer-create "*Racket Trace*"))
- (deactivate-mark deactivate-mark))
- (save-excursion
- (save-restriction
- (with-current-buffer b
- (insert p ": " (if (stringp s) s (format "%S" s)) "\n"))))))
- retval)
-
-(defun racket--toggle-trace (arg)
- (interactive "P")
- (setq racket--trace-enable (or arg (not racket--trace-enable)))
- (if racket--trace-enable
- (message "Racket trace on")
- (message "Racket trace off"))
- (let ((b (get-buffer-create "*Racket Trace*")))
- (pop-to-buffer b t t)
- (setq truncate-lines t)))
-
(defun racket--restoring-current-buffer (proc)
"Return a procedure restoring `current-buffer' during the dynamic extent of PROC."
(let ((buf (current-buffer)))
@@ -127,33 +92,8 @@ When installed as a package, this can be found from the variable
(with-current-buffer buf
(apply proc args)))))
-;;; string trim
-
-;; "inline" the one thing we used from `s' so we can drop the dep.
-;; TO-DO: Rewrite racket--trim more simply; I just don't want to
-;; detour now.
-
-(defun racket--trim-left (s)
- "Remove whitespace at the beginning of S."
- (save-match-data
- (if (string-match "\\`[ \t\n\r]+" s)
- (replace-match "" t t s)
- s)))
-
-(defun racket--trim-right (s)
- "Remove whitespace at the end of S."
- (save-match-data
- (if (string-match "[ \t\n\r]+\\'" s)
- (replace-match "" t t s)
- s)))
-
-(defun racket--trim (s)
- "Remove whitespace at the beginning and end of S."
- (racket--trim-left (racket--trim-right s)))
-
(defun racket--non-empty-string-p (v)
- (and (stringp v)
- (not (string-match-p "\\`[ \t\n\r]*\\'" v)))) ;`string-blank-p'
+ (and (stringp v) (not (string-blank-p v))))
(defun racket--symbol-at-point-or-prompt (force-prompt-p
prompt
@@ -164,7 +104,7 @@ When installed as a package, this can be found from the variable
When FORCE-PROMPT-P always prompt. The prompt uses
`read-from-minibuffer' when COMPLETIONS is nil, else
-`ido-completing-read'.
+`completing-read'.
Returns `stringp' not `symbolp' to simplify using the result in a
sexpr that can be passed to Racket backend. Likewise the string
@@ -176,13 +116,13 @@ as if the user had C-g to quit."
(if (or force-prompt-p
(not sap))
(let* ((s (if completions
- (ido-completing-read prompt completions nil nil sap)
+ (completing-read prompt completions nil nil sap)
(read-from-minibuffer prompt sap)))
(s (if s
- (racket--trim (substring-no-properties s))
+ (string-trim (substring-no-properties s))
s)))
(if (or (not s)
- (and (not allow-blank-p) (equal "" s)))
+ (and (not allow-blank-p) (string-blank-p s)))
nil
s))
sap)))
@@ -196,7 +136,9 @@ The \"project\" is determined by trying, in order:
- `vc-root-dir'
- `project-current'
- `file-name-directory'"
- (let ((dir (file-name-directory file)))
+ (let ((dir (if file
+ (file-name-directory file)
+ default-directory)))
(or (and (fboundp 'projectile-project-root)
(projectile-project-root dir))
(and (fboundp 'vc-root-dir)
diff --git a/racket-visit.el b/racket-visit.el
index b00fee3..669dcd6 100644
--- a/racket-visit.el
+++ b/racket-visit.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'simple)
(require 'xref)
@@ -25,8 +17,8 @@
The returned string has text properties:
-- A 'racket-module-path property whose value is either 'absolute
- or 'relative.
+- A \"racket-module-path\" property whose value is either
+ \"absolute\" or \"relative\".
- The original properties from the buffer. However if a multi-in
form, these are only the properties from the suffix, e.g. the
@@ -34,10 +26,10 @@ The returned string has text properties:
applied only to that portion of the returned string, e.g. the
\"base\" portion of \"racket/base\".
-- Regardless of the preceding point, the original 'racket-xp-def
- property if any from the buffer is applied to the ENTIRE
- returned string. That way the caller can simply use an index of
- 0 for `get-text-property'."
+- Regardless of the preceding point, the original
+ \"racket-xp-def\" property if any from the buffer is applied to
+ the ENTIRE returned string. That way the caller can simply use
+ an index of 0 for `get-text-property'."
(when (racket--in-require-form-p)
(save-excursion
(condition-case ()
@@ -72,6 +64,18 @@ The returned string has text properties:
(get-text-property 0 'racket-xp-def str)))))))
(scan-error nil)))))
+(defun racket--rkt-or-ss-path (path)
+ "Handle the situation of #575 where .rkt doesn't exist but .ss does."
+ (if (file-exists-p path)
+ path
+ (let ((other-path (concat (file-name-sans-extension path)
+ (pcase (file-name-extension path)
+ ("rkt" ".ss")
+ ("ss" ".rkt")))))
+ (if (file-exists-p other-path)
+ other-path
+ path))))
+
(defun racket--pop-to-xref-location (item)
"Similar to the private function `xref--pop-to-location'.
diff --git a/racket-wsl.el b/racket-wsl.el
index aa7dbff..2fec096 100644
--- a/racket-wsl.el
+++ b/racket-wsl.el
@@ -1,32 +1,27 @@
;;; racket-wsl.el -*- lexical-binding: t -*-
-;; Copyright (c) 2020 by Greg Hendershott.
+;; Copyright (c) 2020-2022 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(defvar racket--wslpath (and (eq system-type 'gnu/linux)
(executable-find "wslpath")))
(defun racket--call-wsl-path (pathname flag)
- "When variable `racket--wslpath' is not nil, use it to convert PATHNAME using FLAG.
+ "Wrapper for wslpath.
+
+When variable `racket--wslpath' is not nil, use it to convert
+PATHNAME using FLAG.
wslpath usage:
-a force result to absolute path format
-u translate from a Windows path to a WSL path (default)
-w translate from a WSL path to a Windows path
- -m translate from a WSL path to a Windows path, with ‘/’ instead of ‘\\’
+ -m translate from a WSL path to a Windows path, with \"/\" instead of \"\\\"
"
(if racket--wslpath
(with-temp-buffer
diff --git a/racket-xp-complete.el b/racket-xp-complete.el
index 654da29..50d5d1b 100644
--- a/racket-xp-complete.el
+++ b/racket-xp-complete.el
@@ -6,24 +6,17 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-complete)
(require 'racket-describe)
+(require 'racket-company-doc)
-(defvar racket--xp-binding-completions nil
+(defvar-local racket--xp-binding-completions nil
"Completion candidates that are bindings.
Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
-(defvar racket--xp-module-completions nil
+(defvar-local racket--xp-module-completions nil
"Completion candidates that are available collection module paths.
Set by `racket-xp-mode'. Used by `racket-xp-complete-at-point'.")
@@ -101,18 +94,19 @@ that are require transformers."
(defun racket--xp-make-company-location-proc ()
(when (racket--cmd-open-p)
- (let ((how (buffer-file-name)))
+ (let ((how (racket-how-front-to-back (buffer-file-name))))
(lambda (str)
(let ((str (substring-no-properties str)))
(pcase (racket--cmd/await nil `(def ,how ,str))
- (`(,path ,line ,_) (cons path line))))))))
+ (`(,path ,line ,_)
+ (cons (racket-file-name-back-to-front path) line))))))))
(defun racket--xp-make-company-doc-buffer-proc ()
(when (racket--cmd-open-p)
- (let ((how (buffer-file-name)))
+ (let ((how (racket-how-front-to-back (buffer-file-name))))
(lambda (str)
(let ((str (substring-no-properties str)))
- (racket--do-describe how nil str))))))
+ (racket--company-doc-buffer how str))))))
(provide 'racket-xp-complete)
diff --git a/racket-xp.el b/racket-xp.el
index b4acf52..52dbbd8 100644
--- a/racket-xp.el
+++ b/racket-xp.el
@@ -6,15 +6,7 @@
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
-;; License:
-;; This is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version. This is distributed in the hope that it will be
-;; useful, but without any warranty; without even the implied warranty
-;; of merchantability or fitness for a particular purpose. See the GNU
-;; General Public License for more details. See
-;; http://www.gnu.org/licenses/ for details.
+;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'racket-custom)
(require 'racket-browse-url)
@@ -27,13 +19,15 @@
(require 'racket-visit)
(require 'racket-show)
(require 'racket-xp-complete)
+(require 'racket-back-end)
(require 'easymenu)
(require 'imenu)
(require 'rx)
(require 'seq)
(require 'xref)
-(declare-function racket-complete-at-point "racket-mode.el")
+(declare-function racket-complete-at-point "racket-edit" ())
+(declare-function racket-browse-file-url "racket-browse-url" (path anchor))
;; TODO: Expose as a defcustom? Or even as commands to turn on/off?
;; Also note there are really 3 categories here: 'local 'import
@@ -67,7 +61,8 @@ everything. If you find that too \"noisy\", set this to nil.")
`(("C-c #" ,racket-xp-control-c-hash-keymap)
("M-." ,#'xref-find-definitions)
("C-c C-." ,#'racket-xp-describe)
- ("C-c C-d" ,#'racket-xp-documentation))))
+ ("C-c C-d" ,#'racket-xp-documentation)
+ ("C-c C-s" ,#'racket-describe-search))))
(easy-menu-define racket-xp-mode-menu racket-xp-mode-map
"Menu for `racket-xp-mode'."
@@ -94,6 +89,7 @@ everything. If you find that too \"noisy\", set this to nil.")
"---"
["Racket Documentation" racket-xp-documentation]
["Describe" racket-xp-describe]
+ ["Describe Search" racket-describe-search]
"---"
["Annotate Now" racket-xp-annotate]))
@@ -118,8 +114,8 @@ specific buffer. If you always want to use it, put the following
code in your Emacs init file:
#+BEGIN_SRC elisp
- (require 'racket-xp)
- (add-hook 'racket-mode-hook #'racket-xp-mode)
+ (require \\='racket-xp)
+ (add-hook \\='racket-mode-hook #\\='racket-xp-mode)
#+END_SRC
Note: This mode won't do anything unless/until the Racket Mode
@@ -153,11 +149,11 @@ Note: If you find these point-motion features too distracting
and/or slow, in your `racket-xp-mode-hook' you may disable them:
#+BEGIN_SRC elisp
- (require 'racket-xp)
- (add-hook 'racket-xp-mode-hook
+ (require \\='racket-xp)
+ (add-hook \\='racket-xp-mode-hook
(lambda ()
- (remove-hook 'pre-redisplay-functions
- #'racket-xp-pre-redisplay
+ (remove-hook \\='pre-redisplay-functions
+ #\\='racket-xp-pre-redisplay
t)))
#+END_SRC
@@ -265,12 +261,13 @@ commands directly to whatever keys you prefer.
(racket-xp-tail-position . t)
(racket-xp-tail-target . t)
(racket-xp-visit . t)
- (racket-xp-doc . t))))
+ (racket-xp-doc . t)
+ (racket-xp-require . t))))
(cond (racket-xp-mode
(if (< (buffer-size) racket-xp-buffer-size-limit)
(racket--xp-annotate)
- (setq racket-xp-after-change-refresh-delay nil)
- (message "Extremely large buffer; setting racket-xp-after-change-refresh-delay set to nil"))
+ (setq-local racket-xp-after-change-refresh-delay nil)
+ (message "Extremely large buffer; racket-xp-after-change-refresh-delay locally set to nil"))
(add-hook 'after-change-functions
#'racket--xp-after-change-hook
t t)
@@ -312,54 +309,47 @@ commands directly to whatever keys you prefer.
t))))
(defun racket-xp-describe (&optional prefix)
- "Describe something in a `*Racket Describe*` buffer.
+ "Describe the identifier at point.
-The command varies based on how many \\[universal-argument]
-command prefixes you supply.
-
-0. None.
+The command varies based on how many \\[universal-argument] command prefixes you supply.
+\\<racket-xp-mode-map>
- Uses the symbol at point. If no such symbol exists, you are
- prompted enter the identifier, but in this case it only
- considers definitions or imports at the file's module level --
- not local bindings nor definitions in submodules.
+- \\[racket-xp-describe]
- - If the identifier has installed Racket documentation, then a
- simplified version of the HTML is presented in the buffer,
- including the \"blue box\", documentation prose, and
- examples.
+ Uses the symbol at point. If no such symbol exists, you are
+ prompted enter the identifier, but in this case it only
+ considers definitions or imports at the file's module level --
+ not local bindings nor definitions in submodules.
- - Otherwise, if the identifier is a function, then its
- signature is displayed, for example \"\(name arg-1-name
- arg-2-name\)\".
+ - If the identifier has installed Racket documentation, then a
+ simplified version of the HTML is presented in the buffer,
+ including the \"blue box\", documentation prose, and
+ examples.
-1. \\[universal-argument]
+ - Otherwise, if the identifier is a function, then its
+ signature is displayed, for example \"\(name arg-1-name
+ arg-2-name\)\".
- Always prompts you to enter a symbol, defaulting to the symbol
- at point if any.
+- \\[universal-argument] \\[racket-xp-describe]
- Otheriwse behaves like 0.
+ Always prompts you to enter a symbol, defaulting to the symbol
+ at point if any.
-2. \\[universal-argument] \\[universal-argument]
+- \\[universal-argument] \\[universal-argument] \\[racket-xp-describe]
- This is an alias for `racket-search-describe', which uses
- installed documentation in a `racket-describe-mode' buffer
- instead of an external web browser.
+ This is an alias for `racket-describe-search', which uses
+ installed documentation in a `racket-describe-mode' buffer
+ instead of an external web browser.
The intent is to give a quick reminder or introduction to
something, regardless of whether it has installed documentation
-- and to do so within Emacs, without switching to a web browser.
This buffer is also displayed when you use `company-mode' and
-press F1 or C-h in its pop up completion list.
-
-You can quit the buffer by pressing q. Also, at the bottom of the
-buffer are Emacs buttons -- which you may navigate among using
-TAB, and activate using RET -- for `xref-find-definitions'
-and `racket-xp-documentation'."
+press F1 or C-h in its pop up completion list."
(interactive "P")
(if (equal prefix '(16))
- (racket-search-describe)
+ (racket-describe-search)
(pcase (racket--symbol-at-point-or-prompt prefix "Describe: "
racket--xp-binding-completions)
((and (pred stringp) str)
@@ -370,28 +360,8 @@ and `racket-xp-documentation'."
;; will treat it as a file module identifier.
(let ((how (pcase (get-text-property (point) 'racket-xp-doc)
(`(,path ,anchor) `(,path . ,anchor))
- (_ (racket--buffer-file-name))))
- ;; These two thunks are effectively lazy
- ;; `xref-find-definitions' and `racket-xp-documentation'.
- ;; The thunks might be called later, if/when the user
- ;; "clicks" a "button" in the `racket-describe-mode'
- ;; buffer. By the time that happens, this `racket-mode'
- ;; buffer might no longer exist. Even if it exists, point
- ;; may have changed. That's why it is important to
- ;; capture values from the `racket-mode' buffer, now.
- (visit-thunk
- (pcase (xref-backend-definitions 'racket-xp-xref str)
- (`(,xref) (lambda () (racket--pop-to-xref-location xref)))))
- (doc-thunk
- (pcase (get-text-property (point) 'racket-xp-doc)
- (`(,path ,anchor)
- (lambda ()
- (racket-browse-url (concat "file://" path "#" anchor))))
- (_
- (let ((bfn (racket--buffer-file-name)))
- (lambda ()
- (racket--doc-command nil bfn str)))))))
- (racket--do-describe how nil str t visit-thunk doc-thunk))))))
+ (_ (racket--buffer-file-name)))))
+ (racket--do-describe how nil str))))))
(defun racket-xp-eldoc-function ()
"A value for the variable `eldoc-documentation-function'.
@@ -458,9 +428,25 @@ or `racket-repl-describe'."
(set-window-parameter window 'racket-xp-point point)
(pcase (get-text-property point 'help-echo)
((and s (pred racket--non-empty-string-p))
- (racket-show s
- (or (next-single-property-change point 'help-echo)
- (point-max))))
+ (racket-show
+ s
+ ;; Because some `racket-show' flavors present a tooltip, a
+ ;; position after the end of the span is preferable: less
+ ;; likely to hide the target of the annotation.
+ (pcase (or (next-single-property-change point 'help-echo)
+ (point-max))
+ ((and end (guard (pos-visible-in-window-p end window))) end)
+ ;; But if end isn't visible (#629) prefer beginning.
+ (end
+ (pcase (or (previous-single-property-change end 'help-echo)
+ (point-min))
+ ((and beg (guard (pos-visible-in-window-p beg window))) beg)
+ ;; But if neither beginning nor end are visible, just
+ ;; show starting at top line of window.
+ (_ (save-excursion
+ (goto-char (window-start window))
+ (forward-line -1)
+ (point))))))))
(_ (racket-show "")))
(let ((def (get-text-property point 'racket-xp-def))
(use (get-text-property point 'racket-xp-use)))
@@ -529,36 +515,35 @@ or `racket-repl-describe'."
The command varies based on how many \\[universal-argument]
command prefixes you supply.
+\\<racket-xp-mode-map>
-0. None.
-
- Uses the symbol at point. Tries to find documentation for an
- identifer defined in the expansion of the current buffer.
+- \\[racket-xp-documentation]
- If no such identifer exists, opens the Search Manuals page. In
- this case, the variable `racket-documentation-search-location'
- determines whether the search is done locally as with `raco
- doc`, or visits a URL.
+ Uses the symbol at point. Tries to find documentation for an
+ identifer defined in the expansion of the current buffer.
-1. \\[universal-argument]
+ If no such identifer exists, opens the Search Manuals page. In
+ this case, the variable `racket-documentation-search-location'
+ determines whether the search is done locally as with `raco
+ doc`, or visits a URL.
- Always prompts you to enter a symbol, defaulting to the symbol
- at point if any.
+- \\[universal-argument] \\[racket-xp-documentation]
- Otherwise behaves like 0.
+ Always prompts you to enter a symbol, defaulting to the symbol
+ at point if any.
-2. \\[universal-argument] \\[universal-argument]
+- \\[universal-argument] \\[universal-argument] \\[racket-xp-documentation]
- Always prompts you to enter anything, defaulting to the symbol
- at point if any.
+ Always prompts you to enter anything, defaulting to the symbol
+ at point if any.
- Proceeds directly to the Search Manuals page. Use this if you
- would like to see documentation for all identifiers named
- \"define\", for example."
+ Proceeds directly to the Search Manuals page. Use this if you
+ would like to see documentation for all identifiers named
+ \"define\", for example."
(interactive "P")
(pcase (get-text-property (point) 'racket-xp-doc)
((and `(,path ,anchor) (guard (not prefix)))
- (racket-browse-url (concat "file://" path "#" anchor)))
+ (racket-browse-file-url path anchor))
(_
(racket--doc prefix (buffer-file-name) racket--xp-binding-completions))))
@@ -773,8 +758,7 @@ evaluation errors that won't be found merely from expansion -- or
'racket-xp-xref)
(cl-defmethod xref-backend-identifier-at-point ((_backend (eql racket-xp-xref)))
- (or (racket--module-path-name-at-point)
- (thing-at-point 'symbol)))
+ (thing-at-point 'symbol))
(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql racket-xp-xref)))
(completion-table-dynamic
@@ -783,21 +767,23 @@ evaluation errors that won't be found merely from expansion -- or
(cl-defmethod xref-backend-definitions ((_backend (eql racket-xp-xref)) str)
(or
- (pcase (get-text-property 0 'racket-module-path str)
- (`absolute
- (pcase (racket--cmd/await nil `(mod ,(substring-no-properties str)))
- (`(,path ,line ,col)
- (list (xref-make str (xref-make-file-location path line col))))))
- (`relative
- (let ((path (expand-file-name (substring-no-properties str 1 -1))))
- (list (xref-make str (xref-make-file-location path 1 0))))))
+ ;; Something annotated as add-open-reuqire-menu by drracket/check-syntax
+ (when-let (path (get-text-property 0 'racket-xp-require str))
+ (list (xref-make str (xref-make-file-location path 1 0))))
;; Something annotated for jump-to-definition by drracket/check-syntax
(pcase (get-text-property 0 'racket-xp-visit str)
(`(,path ,subs ,ids)
- (pcase (racket--cmd/await nil `(def/drr ,(racket--buffer-file-name) ,path ,subs ,ids))
+ (pcase (racket--cmd/await nil
+ `(def/drr
+ ,(racket-file-name-front-to-back
+ (racket--buffer-file-name))
+ ,(racket-file-name-front-to-back path)
+ ,subs
+ ,ids))
(`(,path ,line ,col)
(list (xref-make str
- (xref-make-file-location path line col)))))))
+ (xref-make-file-location
+ (racket-file-name-back-to-front path) line col)))))))
(pcase (get-text-property 0 'racket-xp-use str)
(`(,beg ,end)
(list
@@ -810,7 +796,8 @@ evaluation errors that won't be found merely from expansion -- or
(xref-backend-definitions 'racket-xref-module id)))
;; Something that, for whatever reason, drracket/check-syntax did
;; not annotate.
- (pcase (racket--cmd/await nil `(def ,(racket--buffer-file-name)
+ (pcase (racket--cmd/await nil `(def ,(racket-file-name-front-to-back
+ (racket--buffer-file-name))
,(substring-no-properties str)))
(`(,path ,line ,col)
(list (xref-make str
@@ -852,7 +839,16 @@ evaluation errors that won't be found merely from expansion -- or
(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)
@@ -881,9 +877,10 @@ 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."
- (with-current-buffer buffer
- (unless (racket--xp-completing-p)
- (racket--xp-annotate))))
+ (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?
@@ -898,8 +895,9 @@ This is ad hoc and forensic."
"Call `racket-xp-annotate' in all `racket-xp-mode' buffers."
(interactive)
(let ((buffers (seq-filter (lambda (buffer)
- (with-current-buffer buffer
- racket-xp-mode))
+ (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?"
@@ -926,43 +924,45 @@ manually."
(dolist (window windows)
(racket-xp--force-redisplay window)))))))
-(defvar racket--xp-imenu-index nil)
+(defvar-local racket--xp-imenu-index nil)
(defun racket--xp-annotate (&optional after-thunk)
(racket--xp-set-status 'running)
- (racket--cmd/async
- nil
- `(check-syntax ,(or (racket--buffer-file-name) (buffer-name))
- ,(buffer-substring-no-properties (point-min) (point-max)))
- (racket--restoring-current-buffer
- (lambda (response)
- (racket-show "")
- (racket--xp-clear-errors)
- (pcase response
- (`(check-syntax-ok
- (completions . ,completions)
- (imenu . ,imenu)
- (annotations . ,annotations))
- (racket--xp-clear)
- (setq-local racket--xp-binding-completions completions)
- (setq-local 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))))))))
+ (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."
@@ -971,30 +971,29 @@ manually."
(dolist (x xs)
(pcase x
(`(error ,path ,beg ,end ,str)
- (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))))
+ (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)
- (add-text-properties
- beg end
- (list 'help-echo 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)
- (add-text-properties
- beg end
- (list 'help-echo "unused require"))
+ (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))
@@ -1003,21 +1002,19 @@ manually."
(copy-marker pos t))
use))
uses)))
- (add-text-properties
- (marker-position def-beg)
- (marker-position def-end)
- (list 'racket-xp-def (list req id 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))
- (add-text-properties
- (marker-position use-beg)
- (marker-position use-end)
- (append
- (list 'racket-xp-use (list def-beg def-end))))))))
+ (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 (tail) (copy-marker tail t))
+ (calls (mapcar (lambda (call)
+ (copy-marker call t))
calls)))
(put-text-property (marker-position target)
(1+ (marker-position target))
@@ -1031,11 +1028,13 @@ manually."
(`(jump ,beg ,end ,path ,subs ,ids)
(add-text-properties
beg end
- (list 'racket-xp-visit (list path subs ids))))
+ (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 path anchor))))))))
+ (list 'racket-xp-doc
+ (list (racket-file-name-back-to-front path) anchor))))))))
(defun racket--xp-clear (&optional only-errors-p)
(with-silent-modifications
@@ -1045,8 +1044,8 @@ manually."
(remove-text-properties (point-min) (point-max)
(list 'help-echo nil))
(unless only-errors-p
- (setq-local racket--xp-binding-completions nil)
- (setq-local racket--xp-imenu-index nil)
+ (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
@@ -1058,7 +1057,8 @@ manually."
'racket-xp-tail-position nil
'racket-xp-tail-target nil
'racket-xp-visit nil
- 'racket-xp-doc nil)))))
+ 'racket-xp-doc nil
+ 'racket-xp-require nil)))))
;;; Mode line status
diff --git a/racket/command-server.rkt b/racket/command-server.rkt
index 12bccc2..5463b22 100644
--- a/racket/command-server.rkt
+++ b/racket/command-server.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
@@ -8,12 +11,11 @@
"elisp.rkt"
(only-in "instrument.rkt" get-uncovered get-profile)
"logger.rkt"
- "mod.rkt"
"repl.rkt"
"repl-session.rkt"
(only-in "scribble.rkt"
- documented-export-names
- libs+paths+anchors-exporting-documented
+ doc-index-names
+ doc-index-lookup
libs-exporting-documented)
"util.rkt")
@@ -63,6 +65,9 @@
(define response-channel (make-channel))
(define (do-command/queue-response nonce sid sexp)
+ ;; Make "label" for logging. A thread name comes from its thunk ∴
+ ;; renaming the thunk lets us log the thread more informatively.
+ (define label (command-invocation-label nonce sid sexp))
(define (thk)
(channel-put
response-channel
@@ -70,24 +75,23 @@
nonce
(with-handlers ([exn:fail? (λ (e) `(error ,(exn-message e)))]
[exn:break? (λ (e) `(break))])
- `(ok ,(call-with-session-context sid command sexp))))))
- ;; Make "label" for logging. A thread name comes from its thunk ∴
- ;; renaming the thunk lets us log the thread more informatively.
- (define label (command-invocation-label nonce sid sexp))
- (log-racket-mode-info label)
+ (with-time/log label
+ `(ok ,(call-with-session-context sid command sexp)))))))
(procedure-rename thk (string->symbol label)))
(define (write-responses-forever)
- (elisp-writeln (sync response-channel
- logger-notify-channel
- debug-notify-channel)
- out)
- (flush-output out)
- (write-responses-forever))
+ (parameterize ([current-output-port out])
+ (let loop ()
+ (elisp-writeln (sync response-channel
+ logger-notify-channel
+ debug-notify-channel))
+ (flush-output)
+ (loop))))
;; With all the pieces defined, let's go:
(thread write-responses-forever)
- (elisp-writeln `(ready) out)
+ (parameterize ([current-output-port out])
+ (elisp-writeln `(ready)))
(let read-a-command ()
(match (elisp-read in)
[(list* nonce sid sexp) (thread (do-command/queue-response nonce sid sexp))
@@ -105,9 +109,7 @@
(define/contract (command sexpr)
(-> pair? any/c)
- (define-values (dir file mod-path) (maybe-mod->dir/file/rmp
- (current-session-maybe-mod)))
- (define path (and dir file (build-path dir file)))
+ (define file (maybe-module-path->file (current-session-maybe-mod)))
;; Note: Intentionally no "else" match clause -- let caller handle
;; exn and supply a consistent exn response format.
(match sexpr
@@ -133,14 +135,13 @@
[`(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)]
- [`(find-collection ,str) (find-collection str)]
[`(module-names) (module-names)]
[`(requires/tidy ,reqs) (requires/tidy reqs)]
[`(requires/trim ,path-str ,reqs) (requires/trim path-str reqs)]
[`(requires/base ,path-str ,reqs) (requires/base path-str reqs)]
[`(requires/find ,str) (libs-exporting-documented str)]
- [`(doc-index-names) (documented-export-names)]
- [`(doc-index-lookup ,str) (libs+paths+anchors-exporting-documented str)]
+ [`(doc-index-names) (doc-index-names)]
+ [`(doc-index-lookup ,str) (doc-index-lookup str)]
;; Commands that MIGHT need a REPL session for context (e.g. its
;; namespace), if their first "how" argument is 'namespace.
@@ -155,17 +156,16 @@
;; now?
[`(run ,what ,subs ,mem ,pp? ,cols ,pix/char ,ctx ,args ,dbg)
(run what subs mem pp? cols pix/char ctx args dbg)]
- [`(path) (or path 'top)]
+ [`(path) (or file 'top)]
[`(syms) (syms)]
[`(mod ,sym) (find-module sym (current-session-maybe-mod))]
[`(get-profile) (get-profile)]
- [`(get-uncovered) (get-uncovered path)]
+ [`(get-uncovered) (get-uncovered file)]
[`(eval ,v) (eval-command v)]
[`(repl-submit? ,str ,eos?) (repl-submit? str eos?)]
- [`(debug-eval ,src ,l ,c ,p ,code) (debug-eval src l c p code)]
[`(debug-resume ,v) (debug-resume v)]
[`(debug-disable) (debug-disable)]
- [`(break ,kind) (break-repl-thread (current-session-id) kind)]
+ [`(break ,kind) (repl-break kind)]
[`(repl-zero-column) (repl-zero-column)]))
;;; A few commands defined here
@@ -180,22 +180,9 @@
(sort (map symbol->string (namespace-mapped-symbols))
string<?))
-;;; eval-commmand
-
(define/contract (eval-command str)
(-> string? string?)
(call-with-values (λ ()
((current-eval) (string->namespace-syntax str)))
(λ vs
(apply ~a #:separator "\n" (map ~v vs)))))
-
-;;; find-collection
-
-(define-polyfill (find-collection-dir str)
- #:module find-collection/find-collection
- (error 'find-collection-dir
- "For this to work, you need to `raco pkg install raco-find-collection`"))
-
-(define/contract (find-collection str)
- (-> path-string? (listof string?))
- (map path->string (find-collection-dir str)))
diff --git a/racket/commands/check-syntax.rkt b/racket/commands/check-syntax.rkt
index e04b2af..21a5c1a 100644
--- a/racket/commands/check-syntax.rkt
+++ b/racket/commands/check-syntax.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require data/interval-map
@@ -124,6 +127,7 @@
(define ht-imenu (make-hash))
(define local-completion-candidates (mutable-set))
(define ht-tails (make-hash))
+ (define im-requires (make-interval-map))
;; I've seen drracket/check-syntax return bogus positions for e.g.
;; add-mouse-over-status so here's some validation.
@@ -157,6 +161,9 @@
(add1 use-end))))
(set))
(unless require-arrow?
+ ;; For now assume this means a local binding and add a
+ ;; "defined locally" annotation. Below we'll detect the
+ ;; issue #639 scenario and possibly remove this.
(send this syncheck:add-mouse-over-status "" use-beg use-end "defined locally"))))
(define/override (syncheck:add-tail-arrow from-src from-pos to-src to-pos)
@@ -266,6 +273,10 @@
(when (valid-beg/end? beg end)
(interval-map-set! im-unused-requires beg end (list))))
+ (define/override (syncheck:add-require-open-menu _src beg end file)
+ (when (valid-beg/end? beg end)
+ (interval-map-set! im-requires beg end (list file))))
+
(define/public (get-annotations)
;; Obtain any online-check-syntax log message values and treat
;; them as mouse-overs.
@@ -294,9 +305,18 @@
(match-define (cons beg end) beg/end)
(list* sym (add1 beg) (add1 end) (proc vs))))
(define (mouse-over-set->result v)
- (list ;im->list expects a list
- (string-join (sort (set->list v) string<=?)
- "; ")))
+ ;; It is possible for syncheck:add-arrow to be called both
+ ;; with require-arrow? true and false for the same binding.
+ ;; See #639. In that case, assume it's actually imported and
+ ;; remove "defined locally" from the set of annotations.
+ (let ([v (if (and (set-member? v "defined locally")
+ (for/or ([s (in-set v)])
+ (regexp-match? #"^imported from" s)))
+ (set-remove v "defined locally")
+ v)])
+ (list ;im->list expects a list
+ (string-join (sort (set->list v) string<=?)
+ "; "))))
;; Append all and sort by `beg` position
(sort (append
defs/uses
@@ -304,7 +324,8 @@
(im->list im-mouse-overs 'info mouse-over-set->result)
(im->list im-jumps 'jump)
(im->list im-docs 'doc)
- (im->list im-unused-requires 'unused-require))
+ (im->list im-unused-requires 'unused-require)
+ (im->list im-requires 'require))
< #:key cadr))
(define/public (get-local-completion-candidates)
diff --git a/racket/commands/describe.rkt b/racket/commands/describe.rkt
index b2ad8d7..eb68aac 100644
--- a/racket/commands/describe.rkt
+++ b/racket/commands/describe.rkt
@@ -1,13 +1,17 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
racket/format
racket/match
racket/port
- (only-in xml xexpr->string)
(only-in "../find.rkt" find-signature)
"../identifier.rkt"
- "../scribble.rkt")
+ (only-in "../scribble.rkt"
+ identifier->bluebox
+ binding->path+anchor))
(provide type
describe)
@@ -47,67 +51,57 @@
;;; describe
-;; If a symbol has installed documentation, display it.
+;; When `str` is an identifier for which we can find documentation,
+;; return (cons path anchor).
;;
-;; Otherwise, walk the source to find a function definition signature
-;; (the argument names may have explanatory value). When using a
-;; module->namespace, also look for Typed Racket type or a contract,
-;; if any.
-
+;; Otherwise, try to find a function definition signature (the
+;; argument names may have explanatory value), and/or a Typed Racket
+;; type or a contract, if any. If found return (list 'shr-dom dom)
+;; where dom is the Emacs equivalent of an x-expression.
+;;
+;; Otherwise return #f.
(define/contract (describe how str)
- (-> (or/c how/c
- (cons/c path-string? string?)
- (list/c path-string?))
+ (-> how/c
string?
- string?)
- (or (match how
- [(list (? path-string? path))
- (path+anchor->html (cons path #f))]
- [(cons (? path-string? path) (? string? anchor))
- (path+anchor->html (cons path anchor))]
- [(and (or 'namespace (? path-string?)) how)
- (->identifier how str
- (λ (stx)
- (or (path+anchor->html (binding->path+anchor stx))
- (sig-and/or-type how stx))))])
- (format "Found no documentation for ~v in ~v."
- str how)))
+ any) ;(or/c #f (cons/c path-string? string?) shr-dom)
+ (->identifier
+ how str
+ (λ (stx)
+ (or (binding->path+anchor stx)
+ (sig-and/or-type how stx)))))
(define/contract (sig-and/or-type how stx)
- (-> how/c identifier? string?)
+ (-> how/c identifier? any) ;shr-dom
(define dat (syntax->datum stx))
- (define s (match (find-signature how (symbol->string dat))
- [#f #f]
- [x (~a x)]))
- (define t (and (eq? how 'namespace)
- (type-or-contract stx)))
- (xexpr->string
- `(div ()
- (h1 () ,(or s (~a dat)))
- ,(cond [(not (or s t))
- `(p ()
- (em () ,(if (eq? how 'namespace)
- "(Found no documentation, signature, type, or contract.)"
- "(Found no documentation or signature.)")))]
- [t `(pre () ,t)]
- [else ""])
- (br ()))))
+ (define sig (match (find-signature how (symbol->string dat))
+ [#f #f]
+ [x (~a x)]))
+ (define type (and (eq? how 'namespace)
+ (type-or-contract stx)))
+ (define in (if (eq? how 'namespace) "current-namespace" (~v how)))
+ (and (or sig type)
+ (list 'shr-dom
+ `(div ()
+ (h1 () (code () ,(or sig (~a dat))))
+ (p () ,(if type `(code () ,type) ""))
+ (p () "In " (code () ,in) ".")))))
(module+ test
(require rackunit
- (only-in xml string->xexpr)
"../syntax.rkt")
;; Check something that is in the namespace resulting from
;; module->namespace on, say, this source file.
(parameterize ([current-namespace (module->namespace (syntax-source #'this-file))])
(check-equal?
- ;; Convert back to an xexpr because easier to grok test and also
- ;; older xexpr->string probably used <br /> instead of <br/>.
- (string->xexpr (describe 'namespace "describe"))
- `(div ()
- (h1 () "(describe how str)")
- (pre () "(-" ">" " (or/c (or/c (quote namespace) path-string?) (cons/c path-string? string?) (list/c path-string?)) string? string?)")
- (br ()))))
+ (describe 'namespace "describe")
+ '(shr-dom
+ (div
+ ()
+ (h1 () (code () "(describe how str)"))
+ (p () (code () "(-> (or/c (quote namespace) path-string?) string? any)"))
+ (p () "In " (code () "current-namespace") "."))))
+ (check-false
+ (describe 'namespace "something-not-defined-in-the-namespace")))
;; Check something that is not in the current namespace, but is an
;; identifier in the lexical context of an expanded module form --
@@ -122,7 +116,12 @@
(string->expanded-syntax path-str code-str void)
;; Note that this doesn't find contracts, just sigs.
(check-equal?
- (string->xexpr (describe path-str "fun"))
- `(div ()
- (h1 () "(fun a b c)")
- (br ()))))
+ (describe path-str "fun")
+ `(shr-dom
+ (div ()
+ (h1 () (code () "(fun a b c)"))
+ (p () "")
+ (p () "In " (code () ,(~v path-str)) "."))))
+ (check-false
+ (describe path-str "something-not-defined-in-the-file")))
+
diff --git a/racket/commands/find-module.rkt b/racket/commands/find-module.rkt
index 61c33bc..5477a99 100644
--- a/racket/commands/find-module.rkt
+++ b/racket/commands/find-module.rkt
@@ -1,19 +1,23 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
racket/match
+ racket/path
syntax/modresolve
- "../mod.rkt")
+ "../repl.rkt")
(provide find-module)
(define/contract (find-module str maybe-mod)
- (-> string? (or/c #f mod?)
+ (-> string? (or/c #f module-path?)
(or/c #f (list/c path-string? number? number?)))
- (define-values (dir _file maybe-rmp) (maybe-mod->dir/file/rmp maybe-mod))
- (parameterize ([current-load-relative-directory dir])
- (or (mod-loc str maybe-rmp)
- (mod-loc (string->symbol str) maybe-rmp))))
+ (define file (maybe-module-path->file maybe-mod))
+ (parameterize ([current-load-relative-directory (path-only file)])
+ (or (mod-loc str maybe-mod)
+ (mod-loc (string->symbol str) maybe-mod))))
(define (mod-loc v maybe-rmp)
(match (with-handlers ([exn:fail? (λ _ #f)])
@@ -39,7 +43,7 @@
(list (== requires.rkt) 1 0))
(check-match (find-module "racket/string" mod)
(list pe-racket/string 1 0))))
- (let ([mod (->mod/existing (build-path here "describe.rkt"))])
+ (let ([mod (build-path here "describe.rkt")])
(check-match (find-module "requires.rkt" mod)
(list (== requires.rkt) 1 0))
(check-match (find-module "racket/string" mod)
diff --git a/racket/commands/help.rkt b/racket/commands/help.rkt
index de9ceef..1a9da43 100644
--- a/racket/commands/help.rkt
+++ b/racket/commands/help.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang at-exp racket/base
(require (only-in scribble/core tag?)
diff --git a/racket/commands/macro.rkt b/racket/commands/macro.rkt
index cd616f9..613c474 100644
--- a/racket/commands/macro.rkt
+++ b/racket/commands/macro.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require (only-in macro-debugger/stepper-text
@@ -157,13 +160,19 @@
(define before-file (make-temporary-file-with-text before-text))
(define after-file (make-temporary-file-with-text after-text))
(define out (open-output-string))
- (begin0 (parameterize ([current-output-port out])
- (system (format "diff -U ~a ~a ~a" -U before-file after-file))
- (match (get-output-string out)
- ["" " <empty diff>\n"]
- [(pregexp "\n(@@.+@@\n.+)$" (list _ v)) v]))
- (delete-file before-file)
- (delete-file after-file)))
+ (dynamic-wind
+ void
+ (λ ()
+ (parameterize ([current-output-port out])
+ (system (format "diff -U ~a ~a ~a" -U before-file after-file))
+ (match (regexp-replace* #rx"\r\n" ;#598
+ (get-output-string out)
+ "\n")
+ ["" " <empty diff>\n"]
+ [(pregexp "\n(@@.+@@\n.+)$" (list _ v)) v])))
+ (λ ()
+ (delete-file before-file)
+ (delete-file after-file))))
(define (pretty-format-syntax stx)
(pretty-format #:mode 'write (syntax->datum stx)))
diff --git a/racket/commands/module-names.rkt b/racket/commands/module-names.rkt
index 47af67a..e647dbc 100644
--- a/racket/commands/module-names.rkt
+++ b/racket/commands/module-names.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
diff --git a/racket/commands/requires.rkt b/racket/commands/requires.rkt
index 5a6b127..c758697 100644
--- a/racket/commands/requires.rkt
+++ b/racket/commands/requires.rkt
@@ -1,13 +1,16 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang at-exp racket/base
-(require (only-in macro-debugger/analysis/check-requires show-requires)
- racket/contract
+(require racket/contract
racket/format
racket/function
(only-in racket/list append* append-map add-between filter-map)
racket/match
racket/set
- racket/string)
+ racket/string
+ "../util.rkt")
(provide requires/tidy
requires/trim
@@ -66,6 +69,11 @@
(list/c 'drop module-path? number?))))
(define mod+level? (list/c module-path? number?))
+
+(define-polyfill (show-requires _)
+ #:module macro-debugger/analysis/check-requires
+ (error 'requires "Won't work until you `raco pkg install macro-debugger-lib`"))
+
(define/contract (analyze path-str)
(-> path-string? requires-analysis?)
(define-values (base name _) (split-path (string->path path-str)))
diff --git a/racket/debug-annotator.rkt b/racket/debug-annotator.rkt
index 33a3ab3..adc0bb2 100644
--- a/racket/debug-annotator.rkt
+++ b/racket/debug-annotator.rkt
@@ -1,8 +1,10 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require (for-syntax racket/base)
- gui-debugger/marks
- (only-in mzscheme [apply plain-apply])
+ (only-in racket/base [apply plain-apply]) ;;???
(prefix-in kernel: syntax/kerncase))
;; This is like gui-debugger/annotate except:
@@ -11,20 +13,20 @@
;; matching the syntax it is given. See
;; https://github.com/racket/drracket/issues/230 and below.
;;
-;; 1. Our module-annotate disarms/rearms module level expressions. See
-;; https://github.com/racket/drracket/issues/231 and below.
-;;
-;; 2. "Modernize": Use racket/base not racket/scheme. Don't need
+;; 1. "Modernize": Use racket/base not racket/scheme. Don't need
;; opt-lambda.
;;
-;; 3. We remove the record-bound-id and record-top-level-id callbacks
+;; 2. We remove the record-bound-id and record-top-level-id callbacks
;; that we don't use, from annotate-for-single-stepping (but leave
;; them for now in annotate-stx).
;;
-;; 4. We remove the source arg that is completely unused (I'm guessing
+;; 3. We remove the source arg that is completely unused (I'm guessing
;; historical).
-(provide annotate-for-single-stepping)
+(provide annotate-for-single-stepping
+ mark-source
+ mark-bindings
+ debug-key)
(define (annotate-for-single-stepping stx break? break-before break-after)
(define (break-wrap debug-info annotated raw is-tail?)
@@ -96,25 +98,22 @@
(general-top-level-expr-iterator stx #f)]))
(define (module-annotate stx)
- (syntax-case stx ()
+ (syntax-case (disarm stx) ()
[(_ identifier name mb)
(syntax-case (disarm #'mb) ()
[(plain-module-begin . module-level-exprs)
(with-syntax ([(module . _) stx])
- (quasisyntax/loc stx
- (module identifier name
- #,(rearm
- #'mb
- #`(plain-module-begin
- #,@(map (lambda (e)
- ;; https://github.com/racket/drracket/issues/231
- (rearm
- e
- (module-level-expr-iterator
- (disarm e)
- (list (syntax-e #'identifier)
- (syntax-source #'identifier)))))
- (syntax->list #'module-level-exprs)))))))])]))
+ (rearm
+ stx
+ (quasisyntax/loc stx
+ (module identifier name
+ #,(rearm
+ #'mb
+ #`(plain-module-begin
+ #,@(map (lambda (e) (module-level-expr-iterator
+ e (list (syntax-e #'identifier)
+ (syntax-source #'identifier))))
+ (syntax->list #'module-level-exprs))))))))])]))
(define (module-level-expr-iterator stx module-name)
(kernel:kernel-syntax-case
@@ -138,7 +137,9 @@
(define-values (var ...) #,(annotate #`expr '() #t module-name))
#,(if (syntax-source stx)
#`(begin (#%plain-app
- #,record-top-level-id '#,module-name #'var
+ #,record-top-level-id
+ '#,module-name
+ (quote-syntax var)
(case-lambda
[() var]
[(v) (set! var v)])) ...)
@@ -379,3 +380,49 @@
(define code-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
+
+;;; marks
+
+;; This is the equivalent of gui-debugger/marks that we actually use.
+;; We want to avoid dependency on gui-debugger-lib because it depends
+;; on racket/gui.
+
+(define-struct full-mark-struct (module-name source label bindings values))
+
+;; debug-key: this key will be used as a key for the continuation marks.
+(define-struct debug-key-struct ())
+(define debug-key (make-debug-key-struct))
+
+(define (assemble-debug-info tail-bound free-vars label lifting?)
+ (map make-mark-binding-stx free-vars))
+
+(define (wcm-wrap debug-info expr)
+ (quasisyntax/loc expr (with-continuation-mark #,debug-key #,debug-info #,expr)))
+
+(define (make-debug-info module-name source tail-bound free-vars label lifting? assembled-info-stx)
+ (make-full-mark module-name source label free-vars assembled-info-stx))
+
+(define (make-mark-binding-stx id)
+ #`(case-lambda
+ [() #,id] ; Note: `id` might be undefined; caller must catch exceptions
+ [(v) (set! #,id v)]))
+
+;; the 'varargs' creator is used to avoid an extra cons cell in every mark
+(define (make-make-full-mark-varargs module-name source label bindings)
+ (lambda (values)
+ (make-full-mark-struct module-name source label bindings values)))
+
+(define (make-full-mark module-name source label bindings assembled-info-stx)
+ (datum->syntax #'here
+ `(#%plain-lambda ()
+ (#%plain-app
+ ,(make-make-full-mark-varargs module-name source label bindings)
+ ,assembled-info-stx))))
+
+(define (mark-source mark)
+ (full-mark-struct-source (mark)))
+
+(define (mark-bindings mark)
+ (map list
+ (full-mark-struct-bindings (mark))
+ (full-mark-struct-values (mark))))
diff --git a/racket/debug.rkt b/racket/debug.rkt
index 4357122..dca7456 100644
--- a/racket/debug.rkt
+++ b/racket/debug.rkt
@@ -1,7 +1,9 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require (for-syntax racket/base)
- gui-debugger/marks
racket/contract
racket/format
racket/list
@@ -19,12 +21,13 @@
(require rackunit))
(provide (rename-out [on-break-channel debug-notify-channel])
- debug-eval
debug-resume
debug-disable
make-debug-eval-handler
next-break)
+(define-logger racket-mode-debugger)
+
;; A gui-debugger/marks "mark" is a thunk that returns a
;; full-mark-struct -- although gui-debugger/marks doesn't provide
;; that struct. Instead the thunk can be passed to various accessor
@@ -42,9 +45,8 @@
(-> path? pos/c boolean?)
(set-member? (hash-ref breakable-positions src (seteq)) pos))
-(define/contract (annotate stx)
- (-> syntax? syntax?)
- (define source (syntax-source stx))
+(define/contract (annotate stx #:source [source (syntax-source stx)])
+ (->* (syntax?) (#:source path?) syntax?)
(display-commented (format "Debug annotate ~v" source))
(define-values (annotated breakables)
(annotate-for-single-stepping stx break? break-before break-after))
@@ -54,27 +56,49 @@
(seteq))
annotated)
-;; The first contract is suitable for "edge" with Emacs Lisp. Second
-;; is important for actual `next-break` value so that `break?` compare
-;; of source works; see #425.
-(define break-when/c (or/c 'all 'none (cons/c path-string? pos/c)))
-(define break-when-strict/c (or/c 'all 'none (cons/c path? pos/c)))
+;; These contracts are suitable for "edge" with ELisp.
+(define break-point-elisp/c (list/c path-string? pos/c string? string?))
+(define break-when-elisp/c (or/c 'all 'none (listof break-point-elisp/c)))
+
+;; These contracts are for actual `next-break` value.
+(define break-point/c (list/c path? pos/c any/c (listof symbol?)))
+(define break-when/c (or/c 'all 'none (listof break-point/c)))
+
+(define (from-elisp-break-when v)
+ (if (list? v)
+ (map from-elisp-break-point v)
+ v))
+
+(define/contract from-elisp-break-point
+ (-> break-point-elisp/c break-point/c)
+ (match-lambda
+ [(list path-str pos condition actions)
+ (list (string->path path-str)
+ pos
+ (read (open-input-string condition))
+ (read (open-input-string actions)))]))
(define/contract next-break
- (case-> (-> break-when-strict/c)
- (-> break-when-strict/c void))
+ (case-> (-> break-when/c)
+ (-> break-when/c void))
(let ([v 'none])
(case-lambda [() v]
[(v!) (set! v v!)])))
-;; If this returns #t, either break-before or break-after will be
-;; called next.
+;; Following are the functions we give `annotate-for-single-stepping`,
+;; calls to which it "weaves into" the annotated code. When it calls
+;; `break?` and we return true, next it calls either `break-before` or
+;; `break-after`.
+
(define ((break? src) pos)
(match (next-break)
- ['none #f]
- ['all #t]
- [(cons (== src) (== pos)) #t]
- [_ #f]))
+ ['none #f]
+ ['all #t]
+ [(? list? xs) (for/or ([x (in-list xs)])
+ (match x
+ [(list (== src) (== pos) _condition _actions) x]
+ [_ #f]))]
+ [_ #f]))
(define/contract (break-before top-mark ccm)
(-> mark/c continuation-mark-set? (or/c #f (listof any/c)))
@@ -93,69 +117,130 @@
(define pos (case before/after
[(before) (syntax-position stx)]
[(after) (+ (syntax-position stx) (syntax-span stx) -1)]))
- (define max-width 128)
- (define limit-marker "⋯")
- (define locals
- (for*/list ([binding (in-list (mark-bindings top-mark))]
- [stx (in-value (first binding))]
- [get/set! (in-value (second binding))]
- #:when (and (syntax-original? stx) (syntax-source stx)))
- (list (syntax-source stx)
- (syntax-position stx)
- (syntax-span stx)
- (syntax->datum stx)
- (~v #:max-width max-width
- #:limit-marker limit-marker
- (get/set!)))))
- ;; Start a debug repl on its own thread, because below we're going to
- ;; block indefinitely with (channel-get on-resume-channel), waiting for
- ;; the Emacs front end to issue a debug-resume command.
- (define repl-thread (thread (repl src pos top-mark)))
- ;; The on-break-channel is how we notify the Emacs front-end. This
- ;; is a synchronous channel-put but it should return fairly quickly,
- ;; as soon as the command server gets and writes it. In other words,
- ;; this is sent as a notification, unlike a command response as a
- ;; result of a request.
- (define this-break-id (new-break-id))
- ;; If it is not possible to round-trip serialize/deserialize the
- ;; values, use the original values when stepping (don't attempt to
- ;; substitute user-supplied values).
- (define (maybe-serialized-vals)
- (let ([str (~s vals)])
- (if (and (serializable? vals)
- (<= (string-length str) max-width))
- (cons #t str)
- (cons #f (~s #:max-width max-width
- #:limit-marker limit-marker
- vals)))))
- (channel-put on-break-channel
- (list 'debug-break
- (cons src pos)
- breakable-positions
- locals
- (cons this-break-id
- (case before/after
- [(before) (list 'before)]
- [(after) (list 'after (maybe-serialized-vals))]))))
- ;; Wait for debug-resume command to put to on-resume-channel. If
- ;; wrong break ID, ignore and wait again.
- (let wait ()
- (begin0
- (match (channel-get on-resume-channel)
- [(list break-when (list (== this-break-id) 'before))
- (next-break (calc-next-break before/after break-when top-mark ccm))
- #f]
- [(list break-when (list (== this-break-id) 'before new-vals-str))
- (next-break (calc-next-break before/after break-when top-mark ccm))
- (read-str/default new-vals-str vals)]
- [(list break-when (list (== this-break-id) 'after new-vals-pair))
- (next-break (calc-next-break before/after break-when top-mark ccm))
- (match new-vals-pair
- [(cons #t new-vals-str) (read-str/default new-vals-str vals)]
- [(cons '() _) vals])]
- [_ (wait)])
- (kill-thread repl-thread)
- (newline))))
+
+ ;; What to do depends on whether the break is due to a user
+ ;; breakpoint, and if so, what condition and actions it specifies.
+ (define actions
+ (match ((break? src) pos)
+ [(list _src _pos condition actions)
+ (if (or (equal? condition #t) ;short-cut
+ (with-handlers ([values
+ (λ (e)
+ (display-commented
+ (format "~a\nin debugger condition expression:\n ~v"
+ (exn-message e)
+ condition))
+ #t)]) ;break anyway
+ (eval
+ (call-with-session-context (current-session-id)
+ with-locals
+ condition
+ (mark-bindings top-mark)))))
+ actions
+ null)]
+ ;; Otherwise, e.g. for a simple step, the default and only
+ ;; action is to break.
+ [_ '(break)]))
+
+ (when (memq 'print actions)
+ (unless (null? (mark-bindings top-mark))
+ (display-commented "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!)))))))
+
+ (when (memq 'log actions)
+ (log-racket-mode-debugger-info
+ "watch ~a ~v~a"
+ before/after
+ stx
+ (for*/fold ([str ""])
+ ([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)))
+ (string-append str (format "\n ~a = ~a" stx (~v (get/set!)))))))
+
+ (cond
+ [(memq 'break actions)
+ ;; Start a debug repl on its own thread, because below we're going to
+ ;; block indefinitely with (channel-get on-resume-channel), waiting for
+ ;; the Emacs front end to issue a debug-resume command.
+ (define repl-thread (thread (repl src pos top-mark)))
+ ;; If it is not possible to round-trip serialize/deserialize the
+ ;; values, use the original values when stepping (don't attempt to
+ ;; substitute user-supplied values).
+ (define (maybe-serialized-vals)
+ (let ([str (~s vals)])
+ (if (and (serializable? vals)
+ (<= (string-length str) max-width))
+ (cons #t str)
+ (cons #f (~s #:max-width max-width
+ #:limit-marker limit-marker
+ vals)))))
+ ;; The on-break-channel is how we notify the Emacs front-end. This
+ ;; is a synchronous channel-put but it should return fairly quickly,
+ ;; as soon as the command server gets and writes it. In other words,
+ ;; this is sent as a notification, unlike a command response as a
+ ;; result of a request.
+ (define this-break-id (new-break-id))
+ (define max-width 128)
+ (define limit-marker "⋯")
+ (define locals
+ (for*/list ([binding (in-list (mark-bindings top-mark))]
+ [stx (in-value (first binding))]
+ [get/set! (in-value (second binding))]
+ #:when (and (syntax-original? stx) (syntax-source stx)))
+ (list (syntax-source stx)
+ (syntax-position stx)
+ (syntax-span stx)
+ (syntax->datum stx)
+ (~v #:max-width max-width
+ #:limit-marker limit-marker
+ (get/set!)))))
+ (channel-put on-break-channel
+ (list 'debug-break
+ (cons src pos)
+ breakable-positions
+ locals
+ (cons this-break-id
+ (case before/after
+ [(before) (list 'before)]
+ [(after) (list 'after (maybe-serialized-vals))]))))
+ ;; Wait for debug-resume command to put to on-resume-channel. If
+ ;; wrong break ID, ignore and wait again.
+ (let wait ()
+ (match (channel-get on-resume-channel)
+ [(list (app from-elisp-break-when break-when)
+ (list* (== this-break-id) before/after more))
+ (next-break (calc-next-break break-when before/after top-mark ccm))
+ (begin0
+ ;; The step annotator needs us to return the values to
+ ;; be used when resuming from before or after step --
+ ;; either the original values, or those the user asked
+ ;; to be substituted.
+ (match* [before/after more]
+ [['before (list)]
+ #f]
+ [['before (list new-vals-str)]
+ (read-str/default new-vals-str vals)]
+ [['after (list new-vals-pair)]
+ (match new-vals-pair
+ [(cons #t new-vals-str) (read-str/default new-vals-str vals)]
+ [(cons '() _) vals]) ])
+ (kill-thread repl-thread)
+ (newline))]
+ [_ (wait)]))]
+ ;; Otherwise, if we didn't break, we simply need to (a) calculate
+ ;; next-break and (b) tell the annotator to use the original
+ ;; values (no user substitution).
+ [else
+ (next-break (calc-next-break (next-break) before/after top-mark ccm))
+ (case before/after
+ [(before) #f]
+ [(after) vals])]))
(define (serializable? v)
(with-handlers ([exn:fail:read? (λ _ #f)])
@@ -180,9 +265,9 @@
(with-handlers ([exn:fail:read? (λ _ default)])
(read (open-input-string str))))
-(define/contract (calc-next-break before/after break-when top-mark ccm)
- (-> (or/c 'before 'after) (or/c break-when/c 'over 'out) mark/c continuation-mark-set?
- break-when-strict/c)
+(define/contract (calc-next-break break-when before/after top-mark ccm)
+ (-> (or/c break-when/c 'over 'out) (or/c 'before 'after) mark/c continuation-mark-set?
+ break-when/c)
(define (big-step frames)
(define num-marks (length (debug-marks (current-continuation-marks))))
(or (for/or ([frame (in-list frames)]
@@ -194,18 +279,14 @@
[right (and left (+ left (syntax-span stx) -1))])
(and right
(breakable-position? src right)
- (cons src right))))
+ (list (list src right #t '(break))))))
'all))
- (match* [break-when before/after]
- [['none _] 'none]
- [['all _] 'all]
- [['out _] (big-step (debug-marks ccm))]
- [['over 'before] (big-step (cons top-mark (debug-marks ccm)))]
- [['over 'after] 'all]
- [[(cons (? path? path) pos) _]
- (cons path pos)]
- [[(cons (? path-string? path-str) pos) _]
- (cons (string->path path-str) pos)]))
+ (case break-when
+ [(out) (big-step (debug-marks ccm))]
+ [(over) (case before/after
+ [(before) (big-step (cons top-mark (debug-marks ccm)))]
+ [(after) 'all])]
+ [else break-when])) ;'all, 'none, or user breakpoints
(define break-id/c nat/c)
(define/contract new-break-id
@@ -283,25 +364,12 @@
;;; Command interface
-;; Intended use is for `code` to be a function definition form. It
-;; will be re-defined annotated for single stepping: When executed it
-;; will call our break?, break-before, and break-after functions.
-(define/contract (debug-eval source-str line col pos code)
- (-> path-string? pos/c nat/c pos/c string? #t)
- (define source (string->path source-str))
- (define in (open-input-string code))
- (port-count-lines! in)
- (set-port-next-location! in line col pos)
- (eval (annotate (expand (read-syntax source in))))
- (next-break 'all)
- #t)
-
(define locals/c (listof (list/c path-string? pos/c pos/c symbol? string?)))
(define break-vals/c (cons/c break-id/c
(or/c (list/c 'before)
(list/c 'after (cons/c boolean? string?)))))
(define on-break/c (list/c 'debug-break
- break-when/c
+ (cons/c path? pos/c)
breakable-positions/c
locals/c
break-vals/c))
@@ -311,7 +379,7 @@
(or/c (list/c 'before)
(list/c 'before string?)
(list/c 'after (cons/c elisp-bool/c string?)))))
-(define on-resume/c (list/c (or/c break-when/c 'out 'over) resume-vals/c))
+(define on-resume/c (list/c (or/c break-when-elisp/c 'out 'over) resume-vals/c))
(define/contract on-resume-channel (channel/c on-resume/c) (make-channel))
(define/contract (debug-resume resume-info)
@@ -343,7 +411,10 @@
(let ([orig (current-load/use-compiled)])
(λ (file mod)
(cond [(set-member? files file)
- (load-module/annotate file mod)]
+ (unless (and (pair? mod)
+ (pair? (cdr mod))
+ (module-declared? file #f))
+ (load-module/annotate file mod))]
[else
(orig file mod)])))])
(eval-syntax (annotate (expand-syntax top-stx))))]
diff --git a/racket/elisp.rkt b/racket/elisp.rkt
index 398a224..5b83621 100644
--- a/racket/elisp.rkt
+++ b/racket/elisp.rkt
@@ -1,13 +1,19 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
racket/match
racket/port
- racket/set)
+ racket/set
+ syntax/parse/define)
(provide elisp-read
elisp-bool/c
as-racket-bool
+ with-parens
+ elisp-write
elisp-writeln)
;;; Read a subset of Emacs Lisp values as Racket values
@@ -32,29 +38,49 @@
;;; Write a subset of Racket values as Emacs Lisp values
-(define (elisp-writeln v out)
- (elisp-write v out)
- (newline out))
+(define (elisp-writeln v)
+ (elisp-write v)
+ (newline))
-(define (elisp-write v out)
- (write (racket->elisp v) out))
+(define-simple-macro (with-parens e:expr ...+)
+ (begin (display "(")
+ e ...
+ (display ")")))
-(define (racket->elisp v)
+(define (elisp-write v)
(match v
- [(or #f (list)) 'nil]
- [#t 't]
- [(? list? xs) (map racket->elisp xs)]
- [(cons x y) (cons (racket->elisp x) (racket->elisp y))]
- [(? path? v) (path->string v)]
- [(? hash? v) (for/list ([(k v) (in-hash v)])
- (cons (racket->elisp k) (racket->elisp v)))]
- [(? generic-set? v) (map racket->elisp (set->list v))]
- [(? void?) 'void] ;avoid Elisp-unreadable "#<void>"
- [v v]))
+ [(or #f (list)) (write 'nil)]
+ [#t (write 't)]
+ [(? list? xs) (with-parens
+ (for-each (λ (v)
+ (elisp-write v)
+ (display " "))
+ xs))]
+ [(cons x y) (with-parens
+ (elisp-write x)
+ (display " . ")
+ (elisp-write y))]
+ [(? path? v) (elisp-write (path->string v))]
+ [(? hash? v) (with-parens
+ (hash-for-each v
+ (λ (k v)
+ (elisp-write (cons k v))
+ (display " "))))]
+ [(? generic-set? v) (with-parens
+ (set-for-each v
+ (λ (v)
+ (elisp-write v)
+ (display " "))))]
+ [(? void?) (display "void")] ;avoid Elisp-unreadable "#<void>"
+ [(? procedure? w) (w)]
+ [(or (? number? v)
+ (? symbol? v)
+ (? string? v)) (write v)]
+ [v (eprintf "elisp-write can't write Racket value ~v\n" v)
+ (void)]))
(module+ test
(require rackunit)
(check-equal? (with-output-to-string
- (λ () (elisp-write '(1 #t nil () (a . b) #hash((1 . 2) (3 . 4)))
- (current-output-port))))
- "(1 t nil nil (a . b) ((1 . 2) (3 . 4)))"))
+ (λ () (elisp-write '(1 #t nil () (a . b) #hash((1 . 2) (3 . 4))))))
+ "(1 t nil nil (a . b) ((1 . 2) (3 . 4) ) )"))
diff --git a/racket/error.rkt b/racket/error.rkt
index cef6bfb..ed17dfe 100644
--- a/racket/error.rkt
+++ b/racket/error.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang at-exp racket/base
(require (only-in pkg/db
@@ -13,48 +16,57 @@
"stack-checkpoint.rkt"
"util.rkt")
-(provide display-exn
- racket-mode-error-display-handler
+(provide racket-mode-error-display-handler
prevent-path-elision-by-srcloc->string)
(module+ test
(require rackunit))
-(define (display-exn exn)
- (racket-mode-error-display-handler (exn-message exn) exn))
-
-(define (racket-mode-error-display-handler str v)
- (cond [(exn? v)
- (unless (equal? "Check failure" (exn-message v)) ;rackunit check fails
- (display-commented (complete-paths
- (undo-path->relative-string/library str)))
+(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 (exn:fail:user? 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))]
- [else
- (display-commented str)]))
+ (maybe-suggest-packages v)]
+ [else
+ (display-commented msg)])))
;;; srclocs
(define (display-srclocs exn)
(when (exn:srclocs? exn)
- (define srclocs
- (match ((exn:srclocs-accessor exn) exn)
- ;; Some exceptions like exn:fail:read? include the first
- ;; srcloc in exn-message -- don't show it again.
- [(cons _ xs)
- #:when (or (exn:fail:read? exn)
- (exn:fail:contract:variable? exn))
- xs]
- ;; Some exceptions like exn:fail:syntax? with Typed Racket
- ;; include _all_ in exn-message -- don't show _any_.
- [_
- #:when (exn:fail:syntax? exn)
- '()]
- [xs xs]))
- (for ([s (in-list srclocs)])
- (display-commented (source-location->string s)))))
+ ;; 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)])
@@ -177,8 +189,10 @@
(module+ test
(let ()
(local-require racket/path
- setup/path-to-relative
- drracket/find-module-path-completions)
+ 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))
diff --git a/racket/example/example.rkt.faceup b/racket/example/example.rkt.faceup
deleted file mode 100644
index 7a8a5d2..0000000
--- a/racket/example/example.rkt.faceup
+++ /dev/null
@@ -1,393 +0,0 @@
-«m:;; »«x:-*- racket-indent-sequence-depth: 100; racket-indent-curly-as-sequence: t; -*-
-»
-«m:;;; »«x:NOTE: After changing this file you will need to M-x faceup-write-file
-»«m:;;; »«x:to regenerate the .faceup test comparison file.
-»«m:;;;»«x:
-»«m:;;; »«x:NOTE: You may need to disable certain features -- for example
-»«m:;;; »«x:global-paren-face-mode -- during the M-x faceup-write-file.
-»
-«k:#lang» «v:racket»
-
-(«k:require» xml)
-(«k:provide» valid-bucket-name?)
-
-«m:;; »«x:Various def* forms are font-locked:
-»
-(«k:define» («f:function» foo)
- «:racket-selfeval-face:#t»)
-
-(«k:define» ((«f:curried-function» x) y)
- («b:list» x y))
-
-(«k:define» «v:a-var» «:racket-selfeval-face:10»)
-
-(«b:define/contract» («f:f2» x)
- («b:any/c» . «b:->» . «b:any»)
- «:racket-selfeval-face:#t»)
-
-(«k:define-values» («v:1st-var 2nd-var») («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»))
-
-(define-thing «v:foo») «m:;»«x:bug 276
-»
-«m:;; »«x:let: font-lock identifiers
-»
-(«k:let» ([«v:foo» «:racket-selfeval-face:10»]
- [«v:bar» «:racket-selfeval-face:20»])
- foo)
-
-(«k:let» «f:loop» ([«v:x» «:racket-selfeval-face:10»])
- («k:unless» («b:zero?» x)
- (loop («b:sub1» x))))
-
-(«k:let*» ([«v:foo» «:racket-selfeval-face:10»]
- [«v:bar» «:racket-selfeval-face:20»])
- foo)
-
-(«k:let-values» ([(«v:a» «v:b») («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)])
- («b:values» a b))
-
-(«k:let*-values» ([(«v:a» «v:b») («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)])
- («b:values» a b))
-
-(«k:letrec-values» ([(«v:a» «v:b») («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)])
- («b:values» a b))
-
-(«k:let-syntax» ([«v:foo» #«:racket-selfeval-face:'foo»])
- foo)
-
-(«k:letrec-syntax» ([«v:foo» #«:racket-selfeval-face:'foo»])
- foo)
-
-(«k:let-syntaxes» ([(«v:foo») #«:racket-selfeval-face:'foo»])
- foo)
-
-(«k:letrec-syntaxes» ([(«v:foo») #«:racket-selfeval-face:'foo»])
- foo)
-
-(«k:letrec-syntaxes+values» ([(«v:foo») #«:racket-selfeval-face:'foo»])
- ([(a b) («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)])
- foo)
-
-«m:;; »«x:for/fold is indented correctly:
-»(«k:for/fold» ([str «s:""»])
- ([ss '(«s:"a"» «s:"b"» «s:"c"»)])
- («b:string-append» str ss))
-
-«m:;; »«x:Auto-converts word `lambda` to `λ`:
-»(«k:lambda» (x) «:racket-selfeval-face:#t»)
-
-«m:;; »«x:Or use M-C-y to insert to insert `λ` char.
-»
-«m:;; »«x:Smart indentation for quoted lists:
-»'(«:racket-selfeval-face:1» «:racket-selfeval-face:2»
- «:racket-selfeval-face:3» «:racket-selfeval-face:4»)
-
-«m:;; »«x:Smart indentation for vector literals:
-»#(«:racket-selfeval-face:1» «:racket-selfeval-face:2»
- «:racket-selfeval-face:3» «:racket-selfeval-face:4»)
-
-«m:;; »«x:Smart indentation for Rackjure dict literals:
-»(«k:module» «f:x» «v:rackjure»
- {«:racket-selfeval-face:'a» «:racket-selfeval-face:0»
- «:racket-selfeval-face:'b» «:racket-selfeval-face:2»})
-
-«m:;; »«x:Silly test submodule example.
-»«m:;; »«x:Try using C-c C-f to Fold (hide) it, and C-c C-u to Unfold it.
-»(«k:module+» «f:test»
- («k:require» rackunit)
- (check-true «:racket-selfeval-face:#t»))
-
-«m:;; »«x:Single line comment
-»
-«x:#|
-
-Multi-line
-comment
-
-|#»
-
-«m:;; »«x:Issue 362
-»
-«x:#|aaa() |#»
-
-«x:#|(hello)|#»
-
-«m:#;»«x:(sexpr comment)»
-
-«m:;; »«x:Nested sexpr comments
-»
-(«b:list» «:racket-selfeval-face:2»
- «m:#;»«x:2»)
-
-(«b:list» «:racket-selfeval-face:1»
- «m:#;»«x:4»
- «m:#;»«x:(3)»)
-
-(«k:let» («m:#;»«x:[x #;1]»
- [«v:y» «:racket-selfeval-face:2»])
- y)
-
-«m:;; »«x:Issue 388
-»«:racket-selfeval-face:1» «m:; »«x:#;
-»«:racket-selfeval-face:2»
-
-«m:;; »«x:Issue 408
-»
-«s:"#;"»whatever
-«s:"#;"»(whatever)
-«s:"#;"»
-(whatever)
-
-«m:;; »«x:Issue 432
-»
-«m:#;» «m:#;» «x:'comment-me» «x:'comment-me» «:racket-selfeval-face:'but-not-me»
-
-«m:#;#;» «x:'comment-me» «x:'comment-me» «:racket-selfeval-face:'but-not-me»
-
-«m:#;» «m:#;» «m:#;» «x:'comment-me» «x:'comment-me» «x:'comment-me» «:racket-selfeval-face:'but-not-me»
-
-«m:#;#;#;» «x:'comment-me» «x:'comment-me» «x:'comment-me» «:racket-selfeval-face:'but-not-me»
-
-«m:#;» «m:;; »«x:comment
-»«m:;; »«x:comment
-»«m:#;» «x:#| comment |#»
-«x:'comment-me»
-«x:'comment-me»
-«:racket-selfeval-face:'but-not-me»
-
-
-(«k:define» «v:x» «:racket-here-string-face:#<<FOO
-asdfasdf
-asdfasdf
-asdfasdf
-FOO
-» )
-
-«m:#;»«x:(define x #<<BAR
-asdfasdf
-asdfasdf
-asdfasdf
-BAR
- )»
-
-|identifier with spaces|
-
-|;no comment|
-
-| #|no comment|# |
-
-(«k:define» («f:a-function» x «:racket-keyword-argument-face:#:keyword» [y «:racket-selfeval-face:0»])
- («k:and» («b:append» («b:car» '(«:racket-selfeval-face:1» «:racket-selfeval-face:2» «:racket-selfeval-face:3»))))
- («b:regexp-match?» «:racket-selfeval-face:#rx»«s:"foobar"» «s:"foobar"»)
- («b:regexp-match?» «:racket-selfeval-face:#px»«s:"foobar"» «s:"foobar"»)
- («k:define» «v:a» «:racket-selfeval-face:1»)
- («k:let» ([«v:a» «s:"foo"»]
- [«v:b» «s:"bar"»])
- («b:displayln» b))
- («k:let*» ([«v:a» «s:"foo"»]
- [«v:b» «s:"bar"»])
- («b:displayln» b))
- («k:let-values» ([(«v:a» «v:b») («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)])
- «:racket-selfeval-face:#t»)
- («k:for/list» ([x («k:in-list» («b:list» «:racket-selfeval-face:1» «:racket-selfeval-face:2» («b:list» «:racket-selfeval-face:3» «:racket-selfeval-face:4»)))])
- («k:cond» [(«b:pair?» x) («b:car» x)]
- [«k:else» x])))
-
-«m:;; »«x:Issue 261
-»«s:"@|widget-id|"» @|foo|
-
-«m:;; »«x:Issue 298
-»(«k:define» «v:x» («k:begin» «s:"|"» '\|))
-
-«m:;; »«x:Issue 376
-»(«k:define» «v:||» (|list|))
-
-(«k:define» («f:foo»)
- («k:let» ([«v:x» «:racket-selfeval-face:10»])
- «:racket-selfeval-face:#t»)
-
- («k:let» ([«v:x» «:racket-selfeval-face:1»]
- [«v:y» «:racket-selfeval-face:2»])
- «:racket-selfeval-face:#t»)
-
- («k:define» «v:1/2-the-way» «:racket-selfeval-face:0»)
- («k:define» «v:less-than-1/2» «:racket-selfeval-face:0»)
-
- «m:;; »«x:Self-eval examples
-» («b:values»
- 1/2-the-way «m:;»«x:should NOT be self-eval
-» less-than-1/2 «m:;»«x:should NOT be self-eval
-» «:racket-selfeval-face:+inf.0»
- «:racket-selfeval-face:-inf.0»
- «:racket-selfeval-face:+nan.0»
- «:racket-selfeval-face:#t»
- «:racket-selfeval-face:#f»
- «:racket-selfeval-face:1»
- «:racket-selfeval-face:1.0»
- «:racket-selfeval-face:1/2»
- «:racket-selfeval-face:-1/2»
- «:racket-selfeval-face:#b100»
- «:racket-selfeval-face:#o123»
- «:racket-selfeval-face:#d123»
- «:racket-selfeval-face:#x7f7f»
- «:racket-selfeval-face:'symbol»
- «:racket-selfeval-face:'|symbol with spaces|»
- «:racket-selfeval-face:'|;no comment|»
- «:racket-selfeval-face:'| #|no comment|# |»
- «:racket-selfeval-face:'symbol-with-no-alpha/numeric-chars»
- «:racket-selfeval-face:#\c»
- «:racket-selfeval-face:#\space»
- «:racket-selfeval-face:#\newline»
-
- «m:;; »«x:Literal number examples
-»
- «m:;; »«x:#b
-» «:racket-selfeval-face:#b1.1»
- «:racket-selfeval-face:#b-1.1»
- «:racket-selfeval-face:#b1e1»
- «:racket-selfeval-face:#b0/1»
- «:racket-selfeval-face:#b1/1»
- «:racket-selfeval-face:#b1e-1»
- «:racket-selfeval-face:#b101»
-
- «m:;; »«x:#d
-» «:racket-selfeval-face:#d-1.23»
- «:racket-selfeval-face:#d1.123»
- «:racket-selfeval-face:#d1e3»
- «:racket-selfeval-face:#d1e-22»
- «:racket-selfeval-face:#d1/2»
- «:racket-selfeval-face:#d-1/2»
- «:racket-selfeval-face:#d1»
- «:racket-selfeval-face:#d-1»
-
- «m:;; »«x:No # reader prefix -- same as #d
-» «:racket-selfeval-face:-1.23»
- «:racket-selfeval-face:1.123»
- «:racket-selfeval-face:1e3»
- «:racket-selfeval-face:1e-22»
- «:racket-selfeval-face:1/2»
- «:racket-selfeval-face:-1/2»
- «:racket-selfeval-face:1»
- «:racket-selfeval-face:-1»
-
- «m:;; »«x:#e
-» «:racket-selfeval-face:#e-1.23»
- «:racket-selfeval-face:#e1.123»
- «:racket-selfeval-face:#e1e3»
- «:racket-selfeval-face:#e1e-22»
- «:racket-selfeval-face:#e1»
- «:racket-selfeval-face:#e-1»
- «:racket-selfeval-face:#e1/2»
- «:racket-selfeval-face:#e-1/2»
-
- «m:;; »«x:#i always float
-» «:racket-selfeval-face:#i-1.23»
- «:racket-selfeval-face:#i1.123»
- «:racket-selfeval-face:#i1e3»
- «:racket-selfeval-face:#i1e-22»
- «:racket-selfeval-face:#i1/2»
- «:racket-selfeval-face:#i-1/2»
- «:racket-selfeval-face:#i1»
- «:racket-selfeval-face:#i-1»
-
- «m:;; »«x:#o
-» «:racket-selfeval-face:#o777.777»
- «:racket-selfeval-face:#o-777.777»
- «:racket-selfeval-face:#o777e777»
- «:racket-selfeval-face:#o777e-777»
- «:racket-selfeval-face:#o3/7»
- «:racket-selfeval-face:#o-3/7»
- «:racket-selfeval-face:#o777»
- «:racket-selfeval-face:#o-777»
-
- «m:;; »«x:#x
-» «:racket-selfeval-face:#x-f.f»
- «:racket-selfeval-face:#xf.f»
- «:racket-selfeval-face:#x-f»
- «:racket-selfeval-face:#xf»
-
- «m:;; »«x:exact complex, e.g. issue #445
-» «:racket-selfeval-face:1+2i»
- «:racket-selfeval-face:1/2+3/4i»
- «:racket-selfeval-face:1.0+3.0e7i»
-
- «m:;; »«x:negative exponent, e.g. issue #442
-» «:racket-selfeval-face:2.0e1»
- «:racket-selfeval-face:-2.0e2»
- «:racket-selfeval-face:-1e-1»
- ))
-
-(«b:define/contract» («f:valid-bucket-name?» s «:racket-keyword-argument-face:#:keyword» [dns-compliant? «:racket-selfeval-face:#t»])
- ((«b:string?») («:racket-keyword-argument-face:#:keyword» «b:boolean?») . «b:->*» . «b:boolean?»)
- («k:cond»
- [dns-compliant?
- («k:and» («b:<=» «:racket-selfeval-face:3» («b:string-length» s)) («b:<=» («b:string-length» s) «:racket-selfeval-face:63»)
- («b:not» («b:regexp-match» «:racket-selfeval-face:#px»«s:"\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}"» s))
- («k:for/and» ([s («b:regexp-split» «:racket-selfeval-face:#rx»«s:"\\."» s)])
- («k:define» («f:valid-first-or-last?» c)
- («k:or» («b:char-lower-case?» («b:string-ref» s «:racket-selfeval-face:0»))
- («b:char-numeric?» («b:string-ref» s «:racket-selfeval-face:0»))))
- («k:define» («f:valid-mid?» c)
- («k:or» (valid-first-or-last? c)
- («b:equal?» c «:racket-selfeval-face:#\-»)))
- («k:define» «v:len» («b:string-length» s))
- («k:and» («b:<» «:racket-selfeval-face:0» len)
- (valid-first-or-last? («b:string-ref» s «:racket-selfeval-face:0»))
- (valid-first-or-last? («b:string-ref» s («b:sub1» len)))
- («k:or» («b:<=» len «:racket-selfeval-face:2»)
- («k:for/and» ([c («b:substring» s «:racket-selfeval-face:1» («b:sub1» len))])
- (valid-mid? c))))))]
- [«k:else»
- («k:and» («b:<=» («b:string-length» s) «:racket-selfeval-face:255»)
- («k:for/and» ([c s])
- («k:or» («b:char-numeric?» c)
- («b:char-lower-case?» c)
- («b:char-upper-case?» c)
- («b:equal?» c «:racket-selfeval-face:#\.»)
- («b:equal?» c «:racket-selfeval-face:#\-»)
- («b:equal?» c «:racket-selfeval-face:#\_»))))]))
-
-(«b:displayln» «s:"I'm running!"»)
-
-«m:;; »«x:Issue 366
-»#«s:"1"»
-#«s:"22"»
-#«s:"333"»
-
-«m:;; »«x:Issue 448
-»(fun «:racket-keyword-argument-face:#:1» #«s:"a"»)
-(fun «:racket-keyword-argument-face:#:12» #«s:"a"»)
-(fun «:racket-keyword-argument-face:#:123» #«s:"a"»)
-(fun «:racket-keyword-argument-face:#:1234» #«s:"a"»)
-(fun «:racket-keyword-argument-face:#:1» «:racket-selfeval-face:#px»«s:"a"»)
-(fun «:racket-keyword-argument-face:#:12» «:racket-selfeval-face:#px»«s:"a"»)
-(fun «:racket-keyword-argument-face:#:123» «:racket-selfeval-face:#px»«s:"a"»)
-(fun «:racket-keyword-argument-face:#:1234» «:racket-selfeval-face:#px»«s:"a"»)
-
-«m:;; »«x:Issue 463
-»(«k:or» («b:equal?» c «:racket-selfeval-face:#\"») («b:equal?» c «:racket-selfeval-face:#\'»))
-«:racket-selfeval-face:#\"» «:racket-selfeval-face:#\"»
-«:racket-selfeval-face:#\"» «m:;»«x:comment
-»«:racket-selfeval-face:#\'» «:racket-selfeval-face:#\'»
-«:racket-selfeval-face:#\'» «m:;»«x:comment
-»«:racket-selfeval-face:#\nul» «:racket-selfeval-face:#\null» «:racket-selfeval-face:#\backspace» «:racket-selfeval-face:#\tab» «:racket-selfeval-face:#\vtab» «:racket-selfeval-face:#\newline» «:racket-selfeval-face:#\linefeed»
-«:racket-selfeval-face:#\page» «:racket-selfeval-face:#\return» «:racket-selfeval-face:#\space» «:racket-selfeval-face:#\rubout»
-«:racket-selfeval-face:#\012»
-«:racket-selfeval-face:#\uF»
-«:racket-selfeval-face:#\uFF»
-«:racket-selfeval-face:#\uFFF»
-«:racket-selfeval-face:#\uFFFF»
-«:racket-selfeval-face:#\Ufffff»
-«:racket-selfeval-face:#\Uffffff»
-«:racket-selfeval-face:#\a» «:racket-selfeval-face:#\z»
-«:racket-selfeval-face:#\λ»
-
-«m:;; »«x:Issue 478
-»(«x:#|blah blah blah|#» «k:begin»)
-
-«m:;; »«x:Issue 534
-»(«k:define» «v:foo‾bar» «:racket-selfeval-face:42»)
-(«k:let» ([«v:foo‾bar» «:racket-selfeval-face:42»]) foo‾bar)
-
-«m:;; »«x:Issue 546
-»«:racket-selfeval-face:'C#» («b:add1» «:racket-selfeval-face:1»)
diff --git a/racket/example/indent.rkt.faceup b/racket/example/indent.rkt.faceup
deleted file mode 100644
index f27a8d1..0000000
--- a/racket/example/indent.rkt.faceup
+++ /dev/null
@@ -1,350 +0,0 @@
-«m:;; »«x:-*- racket-indent-sequence-depth: 100; racket-indent-curly-as-sequence: t; -*-
-»
-«m:;;; »«x:NOTE: After changing this file you will need to M-x faceup-write-file
-»«m:;;; »«x:to regenerate the .faceup test comparison file.
-»«m:;;;»«x:
-»«m:;;; »«x:NOTE: You may need to disable certain features -- for example
-»«m:;;; »«x:global-paren-face-mode -- during the M-x faceup-write-file.
-»
-«m:;;; »«x:Quoted list
-»
-'(a b
- (a b
- c))
-
-'((«:racket-selfeval-face:1») «:racket-selfeval-face:2» «:racket-selfeval-face:3»
- («:racket-selfeval-face:3»)
- «:racket-selfeval-face:4» «:racket-selfeval-face:5»)
-
-«m:;;; »«x:Quasiquoted list (align with head) and unquote or unquote-splicing
-»«m:;;; »«x:(use normal indent rules for the form).
-»
-`(Part ()
- (PartNumber ()
- ,part)
- (ETag ()
- ,etag))
-
-`((,(x)
- ,y))
-
-`(Delete
- ,@(«k:for/list» ([p («k:in-list» paths)])
- `(«t:Object» ()
- (Key () ,p))))
-
-«m:;;; »«x:Syntax
-»
-#'(«k:for/list» ([x xs])
- x)
-
-#`(«k:for/list» ([x xs])
- x)
-
-#'(«k:#%app» («k:#%app» «b:hasheq» («k:quote» a) («k:quote» «:racket-selfeval-face:42»))
- («k:quote» a))
-
-(«k:#%app» («k:#%app» «b:hasheq» («k:quote» a) («k:quote» «:racket-selfeval-face:42»))
- («k:quote» a))
-
-#'(foo («k:#%app» «b:hasheq» («k:quote» a) («k:quote» «:racket-selfeval-face:42»))
- («k:quote» a))
-
-«m:;;; »«x:Rackjure style dictionary (when racket-indent-curly-as-sequence is t).
-»
-{a b
- c d}
-
-{a b
- c d
- b '(a x
- s (x y
- x v))}
-
-«m:;;; »«x:Vector
-»
-#(a b
- c d)
-
-«m:;;; »«x:List with a keyword as first member (e.g. in many contracts)
-»
-(«:racket-keyword-argument-face:#:x» y
- «:racket-keyword-argument-face:#:y» x)
-
-«m:;;; »«x:Normal function application.
-»
-(foobar x
- y
- z)
-
-(foobar
- x
- y
- z)
-
-(«b:dict-set» a
- b
- c)
-
-(«b:dict-set»
- a
- b
- c)
-
-(«b:call-with-values» («k:lambda» () («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»))
- «b:+»)
-
-(«b:call-with-values»
- («k:lambda» () («b:values» «:racket-selfeval-face:1» «:racket-selfeval-face:2»))
- «b:+»)
-
-«m:;;; »«x:Forms with special indentation
-»
-(«k:let» ([«v:x» «:racket-selfeval-face:0»])
- x)
-
-«m:;; »«x:indent 2
-»
-(«k:syntax-case» stx ()
- [(«k:_» x) #«:racket-selfeval-face:'#f»]
- [(«k:_» x y) #«:racket-selfeval-face:'#t»])
-
-«m:;; »«x:indent 3
-»
-(«k:syntax-case*» stx () x
- [(«k:_» x) #«:racket-selfeval-face:'#f»]
- [(«k:_» x y) #«:racket-selfeval-face:'#t»])
-
-(«k:syntax-case*»
- stx
- («k:#%module-begin»
- «k:module»
- «k:define-values»
- «k:define-syntaxes»
- «k:define»
- «b:define/contract»
- «k:define-syntax»
- «k:struct»
- «k:define-struct»)
- x
- [(«k:_» x) #«:racket-selfeval-face:'#f»]
- [(«k:_» x y) #«:racket-selfeval-face:'#t»])
-
-«m:;; »«x:begin and cond have 0 style
-»(«k:begin»
- «:racket-selfeval-face:0»
- «:racket-selfeval-face:0»)
-
-(«k:begin» «:racket-selfeval-face:0»
- «:racket-selfeval-face:0»)
-
-(«k:cond» [«:racket-selfeval-face:1» «:racket-selfeval-face:2»]
- [«:racket-selfeval-face:3» «:racket-selfeval-face:4»])
-
-(«k:cond»
- [«:racket-selfeval-face:1» «:racket-selfeval-face:2»]
- [«:racket-selfeval-face:3» «:racket-selfeval-face:4»])
-
-(«k:if» a
- x
- x)
-
-«m:;; »«x:begin*
-»
-(begin-for-foo «:racket-selfeval-face:0»
- «:racket-selfeval-face:0»)
-
-(begin-for-foo
- «:racket-selfeval-face:0»
- «:racket-selfeval-face:0»)
-
-(«k:with-handlers» ([x y])
- a b c)
-
-«m:;; »«x:def, with-, call-with- and other 'defun style
-»
-(«k:define» («f:x») x x
- x)
-
-(«k:struct» x x
- ())
-
-(«b:match-define» («b:list» x y)
- («b:list» «:racket-selfeval-face:1» «:racket-selfeval-face:2»))
-
-(«k:with-output-to-file» path «:racket-keyword-argument-face:#:mode» «:racket-selfeval-face:'text» «:racket-keyword-argument-face:#:exists» «:racket-selfeval-face:'replace»
- («k:λ» () («b:display» «s:"Hello, world."»)))
-
-(«k:call-with-output-file» path «:racket-keyword-argument-face:#:mode» «:racket-selfeval-face:'text» «:racket-keyword-argument-face:#:exists» «:racket-selfeval-face:'replace»
- («k:λ» (out) («b:display» «s:"Hello, world."» out)))
-
-
-«m:;;; »«x:Special forms: When the first non-distinguished form is on the
-»«m:;;; »«x:same line as distinguished forms, disregard it for indent.
-»
-«m:;; »«x:module has indent 2
-»
-(«k:module» «:racket-selfeval-face:1»
- «:racket-selfeval-face:2»
- «:racket-selfeval-face:3»
- «:racket-selfeval-face:4»
- «:racket-selfeval-face:5»)
-
-«m:;; »«x:Normal case
-»(«k:module» «:racket-selfeval-face:1» «:racket-selfeval-face:2»
- «:racket-selfeval-face:3»
- «:racket-selfeval-face:4»
- «:racket-selfeval-face:5»)
-
-«m:;; »«x:Weird case -- but this is how scheme-mode indents it.
-»(«k:module» «:racket-selfeval-face:1» «:racket-selfeval-face:2» «:racket-selfeval-face:3»
- «:racket-selfeval-face:4»
- «:racket-selfeval-face:5»)
-
-«m:;; »«x:Weird case -- but this is how scheme-mode indents it.
-»(«k:module» «:racket-selfeval-face:1» «:racket-selfeval-face:2» «:racket-selfeval-face:3» «:racket-selfeval-face:4»
- «:racket-selfeval-face:5»)
-
-«m:;;; »«x:for/fold
-»
-«m:;; »«x:for/fold untyped, accum on same line
-»(«k:for/fold» ([a «:racket-selfeval-face:0»]
- [b «:racket-selfeval-face:0»])
- ([x «:racket-selfeval-face:0»]
- [y «:racket-selfeval-face:0»])
- «:racket-selfeval-face:#t»)
-
-«m:;; »«x:for/fold untyped, accum on different line
-»(«k:for/fold»
- ([a «:racket-selfeval-face:0»]
- [b «:racket-selfeval-face:0»])
- ([x «:racket-selfeval-face:0»]
- [y «:racket-selfeval-face:0»])
- «:racket-selfeval-face:#t»)
-
-«m:;; »«x:for/fold typed, type on same line
-»(«k:for/fold» «b::» T
- ([a «:racket-selfeval-face:0»]
- [b «:racket-selfeval-face:0»])
- ([x «:racket-selfeval-face:0»]
- [y «:racket-selfeval-face:0»])
- «:racket-selfeval-face:#t»)
-
-«m:;; »«x:for/fold typed, type on different line
-»(«k:for/fold»
- «b::» T
- ([a «:racket-selfeval-face:0»]
- [b «:racket-selfeval-face:0»])
- ([x «:racket-selfeval-face:0»]
- [y «:racket-selfeval-face:0»])
- «:racket-selfeval-face:#t»)
-
-«m:;;; »«x:Bug #50
-»
-'((x
- y) A
- z
- (x
- y) A
- z)
-
-(«b:match» args
- [(«b:list» x) (x
- y)] «k:...»
- [(«b:list» x) (x y)] «k:...»
- [(«b:list» x) (x y)] «k:...»)
-
-(«k:define-syntax» («f:fstruct» stx)
- («b:syntax-parse» stx
- [(«k:_» id:id (field:id «k:...»))
- («k:with-syntax» ([(accessor «k:...»)
- («k:for/list» ([fld («k:in-list» («b:syntax->list» #'(«b:field» «k:...»)))])
- («b:format-id» stx «s:"~a-~a"» («b:syntax->datum» #«:racket-selfeval-face:'id») fld))])
- #'(serializable-struct
- id («b:field» «k:...») «:racket-keyword-argument-face:#:transparent»
- «:racket-keyword-argument-face:#:property» «b:prop:procedure»
- («k:lambda» (self . args)
- («b:match» args
- [(«b:list» «:racket-selfeval-face:'field») (accessor self)] «k:...»
- [(«b:list» («b:list» «:racket-selfeval-face:'field»)) (accessor self)] «k:...»
- [(«b:list» (list-rest «:racket-selfeval-face:'field» fields)) ((accessor self) fields)] «k:...»
- [(list-rest «:racket-selfeval-face:'field» f args)
- («k:struct-copy» id self
- [«b:field» («k:apply» f (accessor self) args)])] «k:...»
- [(list-rest («b:list» «:racket-selfeval-face:'field») f args) «m:;»«x:<-- THIS SEXPR IS INDENTED TOO FAR
-» («k:struct-copy» id self
- [«b:field» («k:apply» f (accessor self) args)])] «k:...»
- [(list-rest (list-rest «:racket-selfeval-face:'field» fields) args)
- («k:struct-copy» id self
- [«b:field» («k:apply» (accessor self) fields args)])] «k:...»))))]))
-
-«m:;; »«x:Bug #123
-»
-#hash([a . (#hash()
- «:racket-selfeval-face:0»)]
- [b . (#hasheq()
- «:racket-selfeval-face:0»)]
- [c . (#fx(«:racket-selfeval-face:0» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)
- «:racket-selfeval-face:0»)]
- [d . (#fx3(«:racket-selfeval-face:0» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)
- «:racket-selfeval-face:0»)]
- [e . (#fl(«:racket-selfeval-face:0.0» «:racket-selfeval-face:1.0» «:racket-selfeval-face:2.0»)
- «:racket-selfeval-face:0»)]
- [f . (#fl3(«:racket-selfeval-face:0.0» «:racket-selfeval-face:1.0» «:racket-selfeval-face:2.0»)
- «:racket-selfeval-face:0»)]
- [g . (#s(foo x)
- «:racket-selfeval-face:0»)]
- [h . (#3(«:racket-selfeval-face:0» «:racket-selfeval-face:1» «:racket-selfeval-face:2»)
- «:racket-selfeval-face:0»)])
-
-«m:;; »«x:Bug #136
-»
-«m:#;»«x:(list 1
- #;2
- 3)»
-
-(«b:list» «:racket-selfeval-face:1»
- «m:#;»«x:(list 1
- (let ([x 2]
- #;[y 3])
- x)
- 3)»
- «:racket-selfeval-face:2»
- «:racket-selfeval-face:3»)
-
-«m:;; »«x:Bug #243
-»(«k:cond» [x y
- z]
- [(«b:=» a x) y
- z])
-
-«m:;; »«x:Bug #262
-»(define-metafunction «v:λL»
- ∪ «b::» (x «k:...») «k:...» «b:->» (x «k:...»)
- [(∪ any_ls «k:...»)
- ,(«k:apply» «b:append» (term (any_ls «k:...»)))])
-
-«m:;; »«x:Issue #516
-»(«k:lambda» (f [a «b::» «t:Number»]
- [b «b::» «t:Number»]) «b::» «t:Number»
- «:racket-selfeval-face:10»)
-
-(«k:lambda» (f [a «b::» «t:Number»]
- [b «b::» «t:Number»])
- «b::» «t:Number»
- «:racket-selfeval-face:10»)
-
-«m:;; »«x:Issue #521
-»(define-judgment-form «v:L»
- «:racket-keyword-argument-face:#:mode» (⇓ I I O O)
- «:racket-keyword-argument-face:#:contract» (⇓ Γ e Δ v)
-
- [----------- Value
- (⇓ Γ v Γ v)]
-
-
- [(⇓ Γ e Δ («k:λ» (y) e_*))
- (⇓ Δ (subst e_* y x) Θ v)
- ------------------------- Application
- (⇓ Γ (e x) Θ v)])
-
diff --git a/racket/find-module-path-completions.rkt b/racket/find-module-path-completions.rkt
index c1f4bad..d89746b 100644
--- a/racket/find-module-path-completions.rkt
+++ b/racket/find-module-path-completions.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
;;; `racket-open-require-path' uses `tq' to run us. We repeatedly
diff --git a/racket/find.rkt b/racket/find.rkt
index 106856c..20345dc 100644
--- a/racket/find.rkt
+++ b/racket/find.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
diff --git a/racket/gui.rkt b/racket/gui.rkt
index 15ac212..a63096b 100644
--- a/racket/gui.rkt
+++ b/racket/gui.rkt
@@ -1,32 +1,40 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
;; Note that racket/gui/dynamic is in `base` package --- requiring it
;; does NOT create a dependency on the `gui-lib` package.
-(require racket/gui/dynamic)
+(require racket/gui/dynamic
+ racket/port
+ racket/system)
(provide txt/gui
make-initial-repl-namespace)
-;; Load racket/gui/base eagerly, if available, instantiating it in our
-;; namespace and under our main custodian (as opposed to those for
-;; user programs). This is our strategy to avoid "racket/gui/base
-;; cannot be instantiated more than once per process". The only reason
-;; it won't be loaded here now is if we're on a minimal Racket
-;; installation where gui-lib is not installed.
-(with-handlers ([exn:fail? void])
- (dynamic-require 'racket/gui/base #f))
-
-;; If that succeeded, then it is important for REPL namespaces
-;; initially to have racket/gui/base _attached_, regardless of whether
-;; a user program _requires_ it. See also issue #555.
-(define-namespace-anchor anchor)
-(define (make-initial-repl-namespace)
- (define ns (make-base-namespace))
- (when (gui-available?)
- (namespace-attach-module (namespace-anchor->empty-namespace anchor)
- 'racket/gui/base
- ns))
- ns)
+;; Attempt to load racket/gui/base eagerly, instantiating it in our
+;; namespace and under our main custodian (as opposed to those used
+;; for user programs). This is our strategy to avoid "racket/gui/base
+;; cannot be instantiated more than once per process".
+;;
+;; The only scenarios where racket/gui/base won't be loaded eagerly
+;; here:
+;;
+;; - It's not available: we're on a minimal Racket installation
+;; where gui-lib is not installed.
+;;
+;; - It can't initialize: e.g. gui-lib is installed but errors with
+;; 'Gtk initialization failed for display ":0"', because we're on a
+;; headless system and our racket process wasn't run using xvfb-run.
+;; Because this leaves gui-lib in a "semi-initialized" state where
+;; `gui-available?` returns true but things don't actually work, we
+;; really want to avoid this, so we check by using another racket
+;; process.
+(when (parameterize ([current-error-port (open-output-nowhere)])
+ (system* (find-executable-path (find-system-path 'exec-file))
+ "-e" "(require racket/gui/base)"))
+ (with-handlers ([exn:fail? void])
+ (dynamic-require 'racket/gui/base #f)))
;; #301: On Windows, show then hide an initial frame.
(when (and (gui-available?)
@@ -38,6 +46,30 @@
(dynamic-send f 'show #t)
(dynamic-send f 'show #f))
+(define-namespace-anchor anchor)
+(define our-ns (namespace-anchor->empty-namespace anchor))
+(define (make-initial-repl-namespace)
+ (define new-ns (make-base-namespace))
+
+ ;; If we loaded racket/gui/base above, then it is important for REPL
+ ;; namespaces initially to have racket/gui/base _attached_,
+ ;; regardless of whether a given user program `require`s it; a user
+ ;; could `require` it at a REPL prompt. See also issue #555.
+ (when (gui-available?)
+ (namespace-attach-module our-ns 'racket/gui/base new-ns))
+
+ ;; Avoid potential problem (IIUC because Racket structs are
+ ;; generative) with file/convertible by attaching the same instance
+ ;; to user namespaces.
+ ;;
+ ;; Always do this. Things like pict-lib work without gui-lib, and we
+ ;; can still do our feature where we "print images in the REPL". To
+ ;; see how we do this using file/convertible, see print.rkt and
+ ;; image.rkt.
+ (namespace-attach-module our-ns 'file/convertible new-ns)
+
+ new-ns)
+
;; Like mz/mr from racket/sandbox.
(define-syntax txt/gui
(syntax-rules ()
diff --git a/racket/identifier.rkt b/racket/identifier.rkt
index 8bb412e..b4bf74f 100644
--- a/racket/identifier.rkt
+++ b/racket/identifier.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
diff --git a/racket/image.rkt b/racket/image.rkt
index 2133ec7..280ab17 100644
--- a/racket/image.rkt
+++ b/racket/image.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
;;; Portions Copyright (C) 2012 Jose Antonio Ortega Ruiz.
@@ -7,14 +10,13 @@
racket/format
racket/match)
-(provide emacs-can-use-svg!
+(provide set-use-svg?!
convert-image)
;; Emacs front end tells us whether SVG is an image file type Emacs
-;; can render.
+;; can render. This comes via a command line flag when we start up.
(define use-svg? #t)
-(define (emacs-can-use-svg! command-line-flag-str)
- (set! use-svg? (equal? command-line-flag-str "--use-svg")))
+(define (set-use-svg?! v) (set! use-svg? v))
(define (convert-image v)
(and (convertible? v)
@@ -37,10 +39,10 @@
(define (convert-and-save v fmt ext)
(define (default-width _) 4096)
- (match (convert v fmt)
+ (match (convert v fmt #f)
[(or (list* (? bytes? bstr) width _) ;bytes+bounds
(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)]
- [_ #f]))
+ [#f #f]))
diff --git a/racket/imports.rkt b/racket/imports.rkt
index 8980c81..6f55159 100644
--- a/racket/imports.rkt
+++ b/racket/imports.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/contract
@@ -62,7 +65,7 @@
(define (handle-raw-require-spec spec lang)
(let loop ([spec spec])
(syntax-case* spec
- (for-meta for-syntax for-template for-label just-meta for-space just-space)
+ (for-meta for-syntax for-template for-label just-meta for-space just-space portal)
symbolic-compare?
[(for-meta _phase specs ...)
(for ([spec (in-syntax #'(specs ...))])
@@ -85,6 +88,7 @@
[(just-space _space specs ...)
(for ([spec (in-syntax #'(specs ...))])
(loop spec))]
+ [(portal id content) (void)]
[raw-module-path
(handle-phaseless-spec #'raw-module-path lang)])))
diff --git a/racket/instrument.rkt b/racket/instrument.rkt
index aa4c90e..656c7c7 100644
--- a/racket/instrument.rkt
+++ b/racket/instrument.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang at-exp racket/base
(require data/interval-map
@@ -146,26 +149,39 @@
#'(#%plain-app set-mcar! v #t))))
(define (get-uncovered source)
- ;; Due to macro expansion (e.g. to an `if` form), there may be
- ;; multiple data points for the exact same source location. We want
- ;; to logically OR them: If any are true, the source location is
- ;; covered.
- (define im (make-interval-map))
- (for ([(stx v) (in-hash test-coverage-info)])
- (define covered? (mcar v))
- (unless covered?
- (when (equal? source (syntax-source stx))
- (define beg (syntax-position stx))
- (define end (+ beg (syntax-span stx)))
- (interval-map-set! im beg end #t))))
- ;; interval-map-set! doesn't merge adjacent identical intervals so:
- (let loop ([xs (dict-keys im)])
- (match xs
- [(list) (list)]
- [(list* (cons beg same) (cons same end) more)
- (loop (list* (cons beg end) more))]
- [(cons this more)
- (cons this (loop more))])))
+ (for/set ([stx (in-list (get-uncovered-expressions source))])
+ (define beg (syntax-position stx))
+ (define end (+ beg (syntax-span stx)))
+ (cons beg end)))
+
+;; from sandbox-lib
+(define (get-uncovered-expressions source)
+ (let* ([xs (hash-map test-coverage-info
+ (lambda (k v) (cons k (mcar v))))]
+ [xs (filter (lambda (x) (and (syntax-position (car x))
+ (equal? (syntax-source (car x)) source)))
+ xs)]
+ [xs (sort xs (lambda (x1 x2)
+ (let ([p1 (syntax-position (car x1))]
+ [p2 (syntax-position (car x2))])
+ (or (< p1 p2) ; earlier first
+ (and (= p1 p2)
+ (> (syntax-span (car x1)) ; wider first
+ (syntax-span (car x2))))))))]
+ [xs (reverse xs)])
+ (if (null? xs)
+ xs
+ (let loop ([xs (cdr xs)] [r (list (car xs))])
+ (if (null? xs)
+ (map car (filter (lambda (x) (not (cdr x))) r))
+ (loop (cdr xs)
+ (cond [(not (and (= (syntax-position (caar xs))
+ (syntax-position (caar r)))
+ (= (syntax-span (caar xs))
+ (syntax-span (caar r)))))
+ (cons (car xs) r)]
+ [(cdar r) r]
+ [else (cons (car xs) (cdr r))])))))))
;;; Profiling
diff --git a/racket/interactions.rkt b/racket/interactions.rkt
index bf7e767..4aa62a3 100644
--- a/racket/interactions.rkt
+++ b/racket/interactions.rkt
@@ -1,6 +1,10 @@
+;; 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")
@@ -15,46 +19,70 @@
;; 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)
- (cond [(exn:fail:network? e)
- (log-racket-mode-info "get-interaction: exn:fail:network")
- (exit 'get-interaction-exn:fail:network)]
- [else 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)
(λ ()
- (define in ((current-get-interaction-input-port)))
(unless (already-more-to-read? in) ;#311
(display-prompt prompt))
- (match (with-stack-checkpoint
- ((current-read-interaction) prompt in))
- [(? eof-object?)
- (log-racket-mode-info "get-interaction: eof")
- (exit 'get-interaction-eof)]
- [v
- (zero-column!)
- v]))))
+ (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 read-able expression on 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 here.
+ ;; 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))
- (thread
- (λ ()
- (channel-put ch
- (with-handlers ([exn:fail? (λ _ #f)])
- (let* ([buf (make-bytes 4096 0)]
- [len (peek-bytes-avail!* buf 0 #f in)]
- [bstr (subbytes buf 0 len)]
- [v (read (open-input-bytes bstr))])
+ (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)))))))
- (sync/timeout 0.01 ch))
+ (begin0 (sync/timeout 0.01 ch)
+ (custodian-shutdown-all cust)))
(define (display-prompt str)
(fresh-line)
diff --git a/racket/keywords.rkt b/racket/keywords.rkt
index ad75c69..9cd23c0 100644
--- a/racket/keywords.rkt
+++ b/racket/keywords.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang typed/racket/no-check
;; Generate lists for Racket keywords, builtins, and types.
diff --git a/racket/logger.rkt b/racket/logger.rkt
index 706fe4f..b7ee9d0 100644
--- a/racket/logger.rkt
+++ b/racket/logger.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang at-exp racket/base
(require racket/match
@@ -15,9 +18,16 @@
(define command-channel (make-channel))
(define notify-channel (make-channel))
-(define (logger-thread)
+;; Go ahead and start our log receiver thread early so we can see our
+;; own racket-mode topic's 'debug level ouput in the front end.
+;;
+;; On the other hand (see #631) set all other topics to the 'fatal
+;; level (least noisy). This avoids sending excessive logger
+;; notifications to the front end, until/unless it gives us the user's
+;; logger configuration, with whatever verbosity they desire.
+(define (racket-mode-log-receiver-thread)
(let wait ([receiver (make-receiver '((racket-mode . debug)
- (* . warning)))])
+ (* . fatal)))])
(sync
(handle-evt command-channel
(λ (v)
@@ -31,10 +41,7 @@
(ensure-topic-in-message topic message)
"\n")))
(wait receiver)])))))
-
-;; Go ahead and start this early so we can see our own
-;; log-racket-mode-xxx ouput in the front end.
-(void (thread logger-thread))
+(void (thread racket-mode-log-receiver-thread))
(define (ensure-topic-in-message topic message)
(match message
diff --git a/racket/main.rkt b/racket/main.rkt
index 146c694..db6289a 100644
--- a/racket/main.rkt
+++ b/racket/main.rkt
@@ -1,28 +1,37 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later.
+
#lang racket/base
(require racket/match
racket/port
version/utils
"command-server.rkt"
- (only-in "image.rkt" emacs-can-use-svg!)
+ (only-in "image.rkt" set-use-svg?!)
"repl.rkt")
(module+ main
- (define expected-version "6.9")
+ ;; Assert Racket minimum version
+ (define minimum-version "6.9")
(define actual-version (version))
- (unless (version<=? expected-version actual-version)
- (error 'racket-mode "needs at least Racket ~a but you have ~a"
- expected-version
+ (unless (version<=? minimum-version actual-version)
+ (error '|Racket Mode back end| "Need Racket ~a or newer but ~a is ~a"
+ minimum-version
+ (find-executable-path (find-system-path 'exec-file))
actual-version))
- (define launch-token
+ ;; Command-line flags (from Emacs front end invoking us)
+ (define-values (launch-token accept-host tcp-port)
(match (current-command-line-arguments)
- [(vector (== "--auth") token svg-flag-str)
- (emacs-can-use-svg! svg-flag-str)
- token]
+ [(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
- (eprintf "Bad command-line arguments: ~v\n" v)
- (exit)]))
+ (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.
@@ -31,5 +40,5 @@
;; 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)
+ (start-repl-session-server launch-token accept-host tcp-port)
(command-server-loop stdin stdout))))
diff --git a/racket/mod.rkt b/racket/mod.rkt
deleted file mode 100644
index 717a52d..0000000
--- a/racket/mod.rkt
+++ /dev/null
@@ -1,152 +0,0 @@
-#lang at-exp racket/base
-
-(require (for-syntax racket/base
- syntax/parse)
- racket/contract/base
- racket/contract/region
- racket/format
- racket/match
- racket/string
- syntax/location
- "util.rkt")
-
-(provide relative-module-path?
- (struct-out mod)
- ->mod/existing
- maybe-mod->dir/file/rmp
- maybe-mod->prompt-string
- maybe-warn-about-submodules)
-
-(module+ test
- (require rackunit))
-
-;; The subset of module-path? with a relative filename
-(define (relative-module-path? v)
- (define (rel-path? v) ;real predicate taking any/c, unlike relative-path?
- (and (path-string? v) (relative-path? v)))
- (and (module-path? v)
- (match v
- [(? rel-path?) #t]
- [(list 'submod (? rel-path?) (? symbol?) ..1) #t]
- [_ #f])))
-
-(module+ test
- (check-true (relative-module-path? "f.rkt"))
- (check-true (relative-module-path? '(submod "f.rkt" a b)))
- (check-false (relative-module-path? "/path/to/f.rkt"))
- (check-false (relative-module-path? '(submod "/path/to/f.rkt" a b)))
- (check-false (relative-module-path? 'racket/base))
- (check-false (relative-module-path? '(submod 'racket/base a b))))
-
-(define-struct/contract mod
- ([dir absolute-path?] ;#<path:/path/to/>
- [file relative-path?] ;#<path:foo.rkt>
- [rmp relative-module-path?]) ;#<path:f.rkt> or '(submod <path:f.rkt> bar)
- #:transparent)
-
-(define/contract (->mod/simple v)
- (-> any/c (or/c #f mod?))
- (match v
- [(? symbol? s) (->mod/simple (~a s))] ;treat 'file.rkt as "file.rkt"
- [(or (? path? ap) (? path-string? ap))
- (let*-values ([(dir file _) (split-path (simplify-path ap))]
- [(dir) (match dir ['relative (current-directory)][dir dir])])
- (mod dir file file))]
- [_ #f]))
-
-(define/contract (->mod v)
- (-> any/c (or/c #f mod?))
- (define-match-expander mm
- (syntax-parser
- [(_ dir:id file:id rmp:id)
- #'(app ->mod/simple (mod dir file rmp))]))
- (match v
- [(list 'submod
- (mm d f _) (? symbol? ss) ..1) (mod d f (list* 'submod f ss))]
- [(list (mm d f _) (? symbol? ss) ..1) (mod d f (list* 'submod f ss))]
- [(list (mm d f mp)) (mod d f mp)]
- [(mm d f mp) (mod d f mp)]
- [_ #f]))
-
-(module+ test
- (define-syntax-rule (= x y) (check-equal? x y))
- (define f.rkt (string->path "f.rkt"))
- ;; rel path
- (let ([dir (current-directory)])
- (= (->mod "f.rkt") (mod dir f.rkt f.rkt))
- (= (->mod 'f.rkt) (mod dir f.rkt f.rkt))
- (= (->mod '(submod "f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '(submod f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '("f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '(f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '("f.rkt")) (mod dir f.rkt f.rkt))
- (= (->mod '(f.rkt)) (mod dir f.rkt f.rkt)))
- ;; abs path
- (let* ([top (case (system-type) [(windows) "\\"] [(unix macosx) "/"])]
- [dir (path->directory-path (build-path top "p" "t"))])
- (= (->mod (build-path "/" "p" "t" "f.rkt")) (mod dir f.rkt f.rkt))
- (= (->mod '/p/t/f.rkt) (mod dir f.rkt f.rkt))
- (= (->mod '(submod "/p/t/f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '(submod /p/t/f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '("/p/t/f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '(/p/t/f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
- (= (->mod '("/p/t/f.rkt")) (mod dir f.rkt f.rkt))
- (= (->mod '(/p/t/f.rkt)) (mod dir f.rkt f.rkt)))
- ;; nonsense input => #f
- (= (->mod 42) #f)
- (= (->mod '(42 'bar)) #f)
- (= (->mod '(submod 42 'bar)) #f)
- (= (->mod '(submod (submod "f.rkt" foo) bar)) #f))
-
-(define/contract (->mod/existing v)
- (-> any/c (or/c #f mod?))
- (match (->mod v)
- [(and v (mod dir file mp))
- (define path (build-path dir file))
- (cond [(file-exists? path) v]
- [else (display-commented (format "~a does not exist" path))
- #f])]
- [_ #f]))
-
-(define/contract (maybe-mod->dir/file/rmp maybe-mod)
- (-> (or/c #f mod?) (values absolute-path?
- (or/c #f relative-path?)
- (or/c #f relative-module-path?)))
- (match maybe-mod
- [(mod d f mp) (values d f mp)]
- [#f (values (current-directory) #f #f)]))
-
-(define/contract (maybe-mod->prompt-string m)
- (-> (or/c #f mod?) string?)
- (match m
- [(mod _ _ (? path? file)) (~a file)]
- [(mod _ _ (list* 'submod xs)) (string-join (map ~a xs) "/")]
- [#f ""]))
-
-;; Check whether Racket is new enough (newer than 6.2.1) that
-;; module->namespace works with module+ and (module* _ #f __)
-;; forms when errortrace is enabled.
-(module+ check
- (define x 42))
-(define (can-enter-module+-namespace?)
- (define mp (quote-module-path check))
- (dynamic-require mp #f)
- (with-handlers ([exn:fail? (λ _ #f)])
- (eval 'x (module->namespace mp))
- #t))
-
-(define warned? #f)
-(define/contract (maybe-warn-about-submodules mp context)
- (-> (or/c #f module-path?) symbol? any)
- (unless (or warned?
- (not (pair? mp)) ;not submodule
- (memq context '(low medium))
- (can-enter-module+-namespace?))
- (set! warned? #t)
- (display-commented
- @~a{Note: @~v[@mp] will be evaluated.
- However your Racket version is old. You will be unable to
- use the REPL to examine definitions in the body of a module+
- or (module* _ #f ___) form when errortrace is enabled. Either
- upgrade Racket, or, set the Emacs variable racket-error-context
- to 'low or 'medium.})))
diff --git a/racket/online-check-syntax.rkt b/racket/online-check-syntax.rkt
index 75a0efe..d96b8d9 100644
--- a/racket/online-check-syntax.rkt
+++ b/racket/online-check-syntax.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/logging
diff --git a/racket/print.rkt b/racket/print.rkt
index e9029a3..9c570e7 100644
--- a/racket/print.rkt
+++ b/racket/print.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/match
@@ -13,10 +16,10 @@
(pretty-print-size-hook (make-pretty-print-size-hook pixels/char))
(pretty-print-print-hook (make-pretty-print-print-hook))]
[else
- (current-print plain-print-handler)])
+ (current-print racket-mode-plain-print-handler)])
(print-syntax-width +inf.0))
-(define (plain-print-handler v)
+(define (racket-mode-plain-print-handler v)
(unless (void? v)
(println (match (convert-image v)
[(cons path-name _pixel-width) path-name]
@@ -34,14 +37,14 @@
;; (Note: Although I had tried using the pre-print and post-print
;; hooks, they seemed to be called inconsistently.)
-(define ht (make-hasheq))
+(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 (not-found)
(match (convert-image value)
[(cons path-name pixel-width)
- (define char-width (ceiling (/ pixel-width pixels/char)))
+ (define char-width (inexact->exact (ceiling (/ pixel-width pixels/char))))
(define path+width (cons path-name char-width))
path+width]
[#f #f]))
diff --git a/racket/repl-session.rkt b/racket/repl-session.rkt
index 0b24a77..39cac5d 100644
--- a/racket/repl-session.rkt
+++ b/racket/repl-session.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang at-exp racket/base
(require racket/format
@@ -32,7 +35,7 @@
(struct session
(thread ;thread? the repl manager thread
repl-msg-chan ;channel?
- maybe-mod ;(or/c #f mod?)
+ maybe-mod ;(or/c #f module-path?)
namespace ;namespace?
submit-pred) ;(or/c #f drracket:submit-predicate/c)
#:transparent)
@@ -62,7 +65,7 @@
(define (call-with-session-context sid proc . args)
(match (get-session sid)
[(? session? s)
- (log-racket-mode-debug @~a{(call-with-session-context @~v[sid] @~v[proc] @~v[args]) => @~v[s]})
+ (log-racket-mode-debug @~a{@car[args]: using session ID @~v[sid]})
(parameterize ([current-session-id sid]
[current-repl-msg-chan (session-repl-msg-chan s)]
[current-session-maybe-mod (session-maybe-mod s)]
@@ -70,7 +73,6 @@
[current-session-submit-pred (session-submit-pred s)])
(apply proc args))]
[_
- (if (equal? sid '())
- (log-racket-mode-debug @~a{(call-with-session-context @~v[sid] @~v[proc] @~v[args]): no specific session})
- (log-racket-mode-warning @~a{(call-with-session-context @~v[sid] @~v[proc] @~v[args]): @~v[sid] not found in @~v[sessions]}))
+ (unless (equal? sid '())
+ (log-racket-mode-warning @~a{@car[args]: session ID @~v[sid] not found}))
(apply proc args)]))
diff --git a/racket/repl.rkt b/racket/repl.rkt
index c87b136..39dac52 100644
--- a/racket/repl.rkt
+++ b/racket/repl.rkt
@@ -1,9 +1,15 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
;; Do NOT use `at-exp` in this file! See issue #290.
(require racket/contract
+ racket/format
racket/match
+ (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"
@@ -11,18 +17,18 @@
"gui.rkt"
"instrument.rkt"
"interactions.rkt"
- "mod.rkt"
"print.rkt"
"repl-session.rkt"
"stack-checkpoint.rkt"
- (only-in "syntax.rkt" with-expanded-syntax-caching-evaluator)
+ (only-in "syntax.rkt" make-caching-load/use-compiled-handler)
"util.rkt")
(provide start-repl-session-server
repl-tcp-port-number
run
- break-repl-thread
- repl-zero-column)
+ repl-break
+ repl-zero-column
+ maybe-module-path->file)
;;; Messages to each repl manager thread
@@ -48,15 +54,9 @@
(define (profile/coverage-level? v) (memq? v profile/coverage-levels))
(define (debug-level? v) (eq? v 'debug))
-;; The message structs
-
-(define-struct/contract repl-manager-thread-message ())
-
-(define-struct/contract (load-gui repl-manager-thread-message)
- ([in-repl? boolean?]))
-
-(define-struct/contract (run-config repl-manager-thread-message)
- ([maybe-mod (or/c #f mod?)]
+;; Attributes that may vary for each run.
+(define-struct/contract run-config
+ ([maybe-mod (or/c #f module-path?)]
[extra-submods (listof (listof symbol?))]
[memory-limit exact-nonnegative-integer?] ;0 = no limit
[pretty-print? boolean?]
@@ -80,13 +80,12 @@
ready-thunk))
;; Command. Called from a command-server thread
-(define/contract (break-repl-thread sid kind)
- (-> any/c (or/c 'break 'hang-up 'terminate) any)
- (match (get-session sid)
- [(struct* session ([thread t]))
- (log-racket-mode-debug "break-repl-thread: ~v ~v" sid kind)
- (break-thread t (case kind [(hang-up terminate) kind] [else #f]))]
- [_ (log-racket-mode-error "break-repl-thread: ~v not in `sessions`" sid)]))
+(struct break (kind))
+(define/contract (repl-break kind)
+ (-> (or/c 'break 'hang-up 'terminate) any)
+ (unless (current-repl-msg-chan)
+ (error 'repl-break "No REPL session to break"))
+ (channel-put (current-repl-msg-chan) (break kind)))
;; Command. Called from a command-server thread
(struct zero-column (chan))
@@ -102,9 +101,16 @@
(unless (current-repl-msg-chan)
(error 'run "current-repl-msg-chan was #f; current-session-id=~v"
(current-session-id)))
+ (define mod-path
+ (match what
+ [(cons (? complete-path? path-string) submods)
+ (define path (simplify-path (string->path path-string)))
+ (if (null? submods)
+ path
+ (list* 'submod path submods))]))
(define ready-channel (make-channel))
(channel-put (current-repl-msg-chan)
- (run-config (->mod/existing what)
+ (run-config mod-path
subs
mem
(as-racket-bool pp)
@@ -120,25 +126,41 @@
;; run with get-profile or get-uncovered.
(sync ready-channel))
+(define/contract (maybe-module-path->file m)
+ (-> (or/c #f module-path?) path?)
+ (match m
+ [(? path? p) p]
+ [(list* 'submod (? path? p) _) p]
+ [#f (current-directory)]))
+
+(define/contract (maybe-module-path->prompt-string m)
+ (-> (or/c #f module-path?) string?)
+ (define (name p)
+ (~a (file-name-from-path p)))
+ (match m
+ [(? path? p) (name p)]
+ [(list* 'submod p xs) (string-join (cons (name p) (map ~a xs)) "/")]
+ [#f ""]))
+
;;; REPL session server
-;; Define these at the module level so that they are initialized when
-;; the module loads -- before other threads like the session manager
-;; or command manager threads try to use them.
-(define listener
- (tcp-listen 0 ;choose port dynamically, a.k.a. "ephemeral" port
- 64
- #f ;reuse? not recommended for ephemeral ports
- "127.0.0.1"))
-(define repl-tcp-port-number
- (let-values ([(_loc-addr port _rem-addr _rem-port) (tcp-addresses listener #t)])
- (log-racket-mode-info "TCP port ~v chosen for REPL sessions" port)
- port))
-
-(define (start-repl-session-server launch-token)
- (thread (listener-thread-thunk launch-token)))
-
-(define ((listener-thread-thunk launch-token))
+(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])
@@ -156,8 +178,10 @@
(parameterize ([current-input-port in]
[current-output-port out]
[current-error-port out])
- (for ([p (in-list (list in out))])
- (file-stream-buffer-mode p 'none)) ;would 'line be sufficient?
+ (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
@@ -167,11 +191,7 @@
(log-racket-mode-fatal "Authorization failed: ~v"
supplied-token)
(exit 'racket-mode-repl-auth-failure))
- ;; port-count-lines! for things like #519, #556. Furthermore
- ;; set current-get-interaction-port to return this so that
- ;; racket/gui/base's override respects it.
- (port-count-lines! in)
- (current-get-interaction-input-port (λ () in))
+ (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)))
@@ -190,7 +210,7 @@
;; 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) (current-output-port))
+ (elisp-writeln `(ok ,session-id))
(flush-output)
(display-commented (string-append "\n" (banner))))))))
@@ -205,11 +225,12 @@
cmd-line-args
debug-files
ready-thunk) cfg)
- (define-values (dir file mod-path) (maybe-mod->dir/file/rmp 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 src-loc->string provide full pathnames
+ ;; Make srcloc->string provide full pathnames
(prevent-path-elision-by-srcloc->string)
;; Custodian for the REPL.
(define repl-cust (make-custodian))
@@ -244,33 +265,21 @@
(instrumenting-enabled (instrument-level? context-level))
(profiling-enabled (eq? context-level 'profile))
(test-coverage-enabled (eq? context-level 'coverage))
+ (current-load/use-compiled (make-caching-load/use-compiled-handler))
;; If module, require and enter its namespace, etc.
- (when (and maybe-mod mod-path)
- (with-expanded-syntax-caching-evaluator
- (with-handlers (;; When exn during module load, display it,
- ;; ask the manager thread to re-run, and wait
- ;; for it to shut down our custodian.
- [exn?
- (λ (exn)
- (display-exn exn)
- (channel-put (current-repl-msg-chan)
- (struct-copy run-config cfg [maybe-mod #f]))
- (sync never-evt))])
- (with-stack-checkpoint
- (maybe-configure-runtime mod-path) ;FIRST: see #281
- (namespace-require mod-path)
- (for ([submod (in-list extra-submods-to-run)])
- (define submod-spec `(submod ,(build-path dir file) ,@submod))
- (when (module-declared? submod-spec)
- (dynamic-require submod-spec #f)))
- ;; User's program may have changed current-directory;
- ;; use parameterize to set for module->namespace but
- ;; restore user's value for REPL.
- (current-namespace
- (parameterize ([current-directory dir])
- (module->namespace mod-path)))
- (maybe-warn-about-submodules mod-path context-level)
- (check-#%top-interaction)))))
+ (when maybe-mod
+ (with-handlers (;; When exn during module load, display it,
+ ;; ask the manager thread to re-run, and wait
+ ;; for it to shut down our custodian.
+ [exn?
+ (λ (exn)
+ ((error-display-handler) (exn-message exn) exn)
+ (channel-put (current-repl-msg-chan)
+ (struct-copy run-config cfg [maybe-mod #f]))
+ (sync never-evt))])
+ (with-stack-checkpoint
+ (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.
@@ -301,81 +310,95 @@
(define thd ((txt/gui (λ _ t/v) eventspace-handler-thread) (current-eventspace)))
thd)))
- (define (clean-up-and-run some-cfg)
- (case context-level
- [(profile) (clear-profile-info!)]
- [(coverage) (clear-test-coverage-info!)])
- (custodian-shutdown-all repl-cust)
- (fresh-line)
- (do-run some-cfg))
-
;; While the repl thread is in read-eval-print-loop, here on the
- ;; repl session thread we wait for messages via repl-msg-chan. Also
- ;; catch breaks, in which case we (a) break the REPL thread so
- ;; display-exn runs there, and (b) continue from our break.
+ ;; repl session thread we wait for messages via repl-msg-chan.
(let get-message ()
- (define message
- (call-with-exception-handler
- (match-lambda
- [(and (or (? exn:break:terminate?) (? exn:break:hang-up?)) e) e]
- [(exn:break _msg _marks continue) (break-thread repl-thread) (continue)]
- [e e])
- (λ () (sync (current-repl-msg-chan)))))
- (match message
- [(? run-config? c) (clean-up-and-run c)]
+ (match (sync (current-repl-msg-chan))
+ [(? run-config? c) (case context-level
+ [(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)
- (get-message)]
- [v (log-racket-mode-warning "ignoring unknown repl-msg-chan message: ~v" v)
- (get-message)])))
-
-(define/contract ((make-prompt-read m))
- (-> (or/c #f mod?) (-> any))
- (begin0 (get-interaction (maybe-mod->prompt-string m))
+ (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)))
+;; Change one of our non-false maybe-mod values (for which we use path
+;; objects, not path-strings) into a module-path applied to
+;; module-path-index-join.
+(define (->module-path mod)
+ (match mod
+ [(? path? p)
+ (module-path-index-join `(file ,(path->string p))
+ #f)]
+ [(list* 'submod (? path? p) subs)
+ (module-path-index-join `(submod "." ,@subs)
+ (module-path-index-join `(file ,(path->string p))
+ #f))]
+ [_ (error "can't make module path from" mod)]))
+
+(define (configure/require/enter mod extra-submods-to-run dir)
+ (define mp (->module-path mod))
+ (configure-runtime mp)
+ (namespace-require mp)
+ (for ([submod (in-list extra-submods-to-run)]) ;e.g. main, test
+ (define sub-mp (module-path-index-join `(submod "." ,@submod) mp))
+ (when (module-declared? sub-mp)
+ (dynamic-require sub-mp #f)))
+ ;; User's program may have changed current-directory, so
+ ;; parameterize for module->namespace, restoring user value for
+ ;; REPL.
+ (current-namespace (parameterize ([current-directory dir])
+ (module->namespace mp))))
+
+;; From racket-lang/racket/src/cs/main.sps
+(define (configure-runtime m)
+ ;; New-style configuration through a `configure-runtime` submodule:
+ (let ([config-m (module-path-index-join '(submod "." configure-runtime) m)])
+ (when (module-declared? config-m #t)
+ (dynamic-require config-m #f)))
+ ;; Old-style configuration with module language info:
+ (let ([info (module->language-info m #t)])
+ (when (and (vector? info) (= 3 (vector-length info)))
+ (let* ([info-load (lambda (info)
+ ((dynamic-require (vector-ref info 0) (vector-ref info 1))
+ (vector-ref info 2)))]
+ [get (info-load info)]
+ [infos (get 'configure-runtime '())])
+ (unless (and (list? infos)
+ (andmap (lambda (info) (and (vector? info) (= 3 (vector-length info))))
+ infos))
+ (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 mod?) (or/c #f drracket:submit-predicate/c))
- (define-values (dir file rmp) (maybe-mod->dir/file/rmp m))
- (define path (and dir file (build-path dir file)))
- (and path rmp
+ (-> (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 (build-path dir file) read-language)
- [(? procedure? get-info)
- (match (get-info 'drracket:submit-predicate #f)
- [#f #f]
- [v v])]
- [_ #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 rmp #t)
+ (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 (maybe-configure-runtime mod-path)
- ;; Do configure-runtime when available.
- ;; Important for langs like Typed Racket.
- (with-handlers ([exn:fail? void])
- (match (module->language-info mod-path #t)
- [(vector mp name val)
- (define get-info ((dynamic-require mp name) val))
- (define configs (get-info 'configure-runtime '()))
- (for ([config (in-list configs)])
- (match-let ([(vector mp name val) config])
- ((dynamic-require mp name) val)))]
- [_ (void)])
- (define cr-submod `(submod
- ,@(match mod-path
- [(list 'submod sub-paths ...) sub-paths]
- [_ (list mod-path)])
- configure-runtime))
- (when (module-declared? cr-submod)
- (dynamic-require cr-submod #f))))
-
(define (check-#%top-interaction)
;; Check that the lang defines #%top-interaction
(unless (memq '#%top-interaction (namespace-mapped-symbols))
diff --git a/racket/scribble.rkt b/racket/scribble.rkt
index f82b064..691d495 100644
--- a/racket/scribble.rkt
+++ b/racket/scribble.rkt
@@ -1,13 +1,11 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
-(require (only-in html
- read-html-as-xml)
- racket/contract
- racket/file
+(require racket/contract
racket/format
- racket/function
racket/match
- racket/path
racket/promise
racket/set
racket/string
@@ -16,18 +14,15 @@
scribble/blueboxes
scribble/manual-struct
scribble/xref
+ scribble/tag
setup/xref
- (only-in xml
- xml->xexpr
- element
- xexpr->string)
- (only-in "util.rkt" log-racket-mode-debug))
+ syntax/parse/define
+ "elisp.rkt")
(provide binding->path+anchor
- path+anchor->html
identifier->bluebox
- documented-export-names
- libs+paths+anchors-exporting-documented
+ doc-index-names
+ doc-index-lookup
libs-exporting-documented)
(module+ test
@@ -35,184 +30,33 @@
(define xref-promise (delay/thread (load-collections-xref)))
+;; When running on a machine with little memory, such as a small VPS
+;; or AWS instance, I have seen the oom-killer terminate the process
+;; after we try to handle a back end command that does some of these
+;; documentation operations. Presumably they use enough memory that
+;; Racket asks the OS for more? To make that less likely, do a major
+;; GC before/after. So far this seems to be a successful mitigation,
+;; although it also seems like a kludge.
+(define (call-avoiding-oom-killer thunk)
+ (collect-garbage 'major)
+ (begin0 (thunk)
+ (collect-garbage 'major)))
+
+(define-simple-macro (with-less-memory-pressure e:expr ...+)
+ (call-avoiding-oom-killer (λ () e ...)))
+
(define/contract (binding->path+anchor stx)
(-> identifier? (or/c #f (cons/c path-string? (or/c #f string?))))
- (let* ([xref (force xref-promise)]
- [tag (xref-binding->definition-tag xref stx 0)]
- [p+a (and tag (tag->path+anchor xref tag))])
- p+a))
+ (with-less-memory-pressure
+ (let* ([xref (force xref-promise)]
+ [tag (xref-binding->definition-tag xref stx 0)]
+ [p+a (and tag (tag->path+anchor xref tag))])
+ p+a)))
(define (tag->path+anchor xref tag)
(define-values (path anchor) (xref-tag->path+anchor xref tag))
(and path anchor (cons path anchor)))
-;;; Scribble docs as HTML suitable for Emacs' shr renderer
-
-(define/contract (path+anchor->html path+anchor)
- (-> (or/c #f (cons/c path-string? (or/c #f string?)))
- (or/c #f string?))
- (match path+anchor
- [(cons path anchor)
- (let* ([xexpr (get-raw-xexpr path anchor)]
- [xexpr (and xexpr (massage-xexpr path xexpr))]
- [html (and xexpr (xexpr->string xexpr))])
- html)]
- [_ #f]))
-
-(define (get-raw-xexpr path anchor)
- (define (heading-element? x)
- (match x
- [(cons (or 'h1 'h2 'h3 'h4 'h5 'h6) _) #t]
- [_ #f]))
- (match (let loop ([es (main-elements (html-file->xexpr path))])
- (match es
- [(list) (list)]
- [(cons (? (curryr anchored-element anchor) this) more)
- ;; Accumulate until another intrapara with an anchor, or
- ;; until a heading element indicating a new subsection.
- (cons this
- (let get ([es more])
- (match es
- [(list) (list)]
- [(cons (? heading-element?) _) (list)] ;stop
- [(cons (? anchored-element) _) (list)] ;stop
- [(cons this more) (cons this (get more))])))]
- [(cons _ more) (loop more)]))
- [(list) #f]
- [xs `(div () ,@xs)]))
-
-(module+ test
- (test-case "procedure"
- (check-not-false (path+anchor->html (binding->path+anchor #'print))))
- (test-case "syntax"
- (check-not-false (path+anchor->html (binding->path+anchor #'match))))
- (test-case "parameter"
- (check-not-false (path+anchor->html (binding->path+anchor #'current-eval))))
- (test-case "indented sub-item"
- (check-not-false (path+anchor->html (binding->path+anchor #'struct-out))))
- (test-case "deftogether"
- (test-case "1 of 2"
- (check-not-false (path+anchor->html (binding->path+anchor #'lambda))))
- (test-case "2 of 2"
- (check-not-false (path+anchor->html (binding->path+anchor #'λ)))))
- (check-not-false (path+anchor->html (binding->path+anchor #'xref-binding->definition-tag))))
-
-(define (main-elements x)
- (match x
- [`(x () "\n"
- (html ()
- (head ,_ . ,_)
- (body ,_
- (div ([class "tocset"]) . ,_)
- (div ([class "maincolumn"])
- (div ([class "main"]) . ,es))
- . ,_)))
- es]
- [_ '()]))
-
-;; anchored-element : xexpr? (or/c #f string?) -> (or/c #f string?)
-;; When `name` is #f, return the first anchor having any name.
-;; Otherwise, return the first anchor having `name`.
-(define (anchored-element x [name #f])
- (define (anchor xs)
- (for/or ([x (in-list xs)])
- (match x
- [`(a ((name ,a)) . ,_) (or (not name) (equal? name a))]
- [`(,_tag ,_attrs . ,es) (anchor es)]
- [_ #f])))
- (match x
- [`(div ((class "SIntrapara"))
- . ,es)
- (anchor es)]
- [`(blockquote ((class "leftindent"))
- (p ())
- (div ((class "SIntrapara"))
- (blockquote ((class "SVInsetFlow"))
- (table ,(list-no-order `(class "boxed RBoxed") _ ...)
- . ,es)))
- ,_ ...)
- (anchor es)]
- [_ #f]))
-
-(define (html-file->xexpr pathstr)
- (xml->xexpr
- (element #f #f 'x '()
- (read-html-as-xml (open-input-string (file->string pathstr))))))
-
-;; This is a big ole pile of poo, attempting to simplify and massage
-;; the HTML so that Emacs shr renders it in the least-worst way.
-;;
-;; Note: Emacs shr renderer removes leading spaces and nbsp from <td>
-;; elements -- which messes up the alignment of s-expressions
-;; including contracts. But actually, the best place to address that
-;; is up in Elisp, not here -- replace in the HTML with some
-;; temporary character, then replace that character in the shr output.
-(define (massage-xexpr html-pathname xexpr)
- ;; In addition to the main x-expression value handled by `walk`, we
- ;; have a couple annoying side values. Rather than "thread" them
- ;; through `walk` as additional values -- literally or using some
- ;; monadic hand-wavery -- I'm just going to set! them. Won't even
- ;; try to hide my sin by using make-parameter. I hereby accept the
- ;; deduction of Functional Experience Points.
- (define kind-xexprs '())
- (define provide-xexprs '())
- (define (walk x)
- (match x
- ;; The "Provided" title/tooltip. Set aside for later.
- [`(span ([title ,(and s (pregexp "^Provided from:"))]) . ,xs)
- (set! provide-xexprs (list s))
- `(span () ,@(map walk xs))]
- ;; The HTML for the "kind" (e.g. procedure or syntax or
- ;; parameter) comes before the rest of the bluebox. Simple HTML
- ;; renderers like shr don't handle this well. Set aside for
- ;; later.
- [`(div ([class "RBackgroundLabel SIEHidden"])
- (div ([class "RBackgroundLabelInner"]) (p () . ,xs)))
- (set! kind-xexprs `((i () ,@xs)))
- ""]
- ;; Bold RktValDef, which is the name of the thing.
- [`(a ([class ,(pregexp "RktValDef|RktStxDef")] . ,_) . ,xs)
- `(b () ,@(map walk xs))]
- ;; Kill links. (Often these won't work anyway -- e.g. due to
- ;; problems with "open" and file: links on macOS.)
- [`(a ,_ . ,xs)
- `(span () ,@(map walk xs))]
- ;; Kill "see also" notes, since they're N/A w/o links.
- [`(div ([class "SIntrapara"])
- (blockquote ([class "refpara"]) . ,_))
- `(span ())]
- ;; Delete some things that produce unwanted blank lines and/or
- ;; indents in simple rendering engines like Emacs' shr.
- [`(blockquote ([class ,(or "SVInsetFlow" "SubFlow")]) . ,xs)
- `(span () ,@(map walk xs))]
- [`(p ([class "RForeground"]) . ,xs)
- `(div () ,@(map walk xs))]
- ;; Let's italicize all RktXXX classes except RktPn.
- [`(span ([class ,(pregexp "^Rkt(?!Pn)")]) . ,xs)
- `(i () ,@(map walk xs))]
- ;; Image sources need path prepended.
- [`(img ,(list-no-order `[src ,src] more ...))
- `(img ([src ,(~a "file://" (path-only html-pathname) src)] . ,more))]
- ;; Misc element: Just walk kids.
- [`(,tag ,attrs . ,xs)
- `(,tag ,attrs ,@(map walk xs))]
- [x x]))
- (match (walk xexpr)
- [`(div () . ,xs)
- (define hs
- (match* [kind-xexprs provide-xexprs]
- [[`() `()] `()]
- [[ks ps] `((span () ,@ks 'nbsp ,@ps))]))
- `(div () ,@hs ,@xs)]))
-
-(module+ test
- (check-equal? ;issue 410
- (massage-xexpr (string->path "/path/to/file.html")
- `(div ()
- (img ([x "x"] [src "foo.png"] [y "y"]))))
- `(div ()
- (img ([src "file:///path/to/foo.png"] [x "x"] [y "y"])))))
-
;;; Blueboxes
(define racket-version-6.10? (equal? (version) "6.10"))
@@ -244,53 +88,112 @@
"(list v ...) -> list?\n v : any/c"))
(check-false (identifier->bluebox (datum->syntax #f (gensym)))))
-;;; Documented exports
-
-(define (documented-export-names)
- (define xref (force xref-promise))
- (define results
- (for*/set ([entry (in-list (xref-index xref))]
- [desc (in-value (entry-desc entry))]
- #:when (exported-index-desc? desc)
- [libs (in-value (exported-index-desc-from-libs desc))]
- #:when (not (null? libs))
- [name (in-value (symbol->string
- (exported-index-desc-name desc)))])
- name))
- (sort (set->list results) string<?))
-
-(define (libs+paths+anchors-exporting-documented sym-as-str)
- (define xref (force xref-promise))
- (define results
- (for*/set ([entry (in-list (xref-index xref))]
- [desc (in-value (entry-desc entry))]
- #:when (exported-index-desc? desc)
- [name (in-value (symbol->string
- (exported-index-desc-name desc)))]
- #:when (equal? name sym-as-str)
- [libs (in-value (map symbol->string
- (exported-index-desc-from-libs desc)))]
- #:when (not (null? libs)))
- (define-values (path anchor)
- (xref-tag->path+anchor xref (entry-tag entry)))
- (list libs (path->string path) anchor)))
- (sort (set->list results)
- string<?
- #:cache-keys? #t
- #:key
- (match-lambda
- [(cons (cons lib _) _)
- (match lib
- [(and (pregexp "^racket/") v)
- (string-append "0_" v)]
- [(and (pregexp "^typed/racket/") v)
- (string-append "1_" v)]
- [v v])])))
-
+;;; Documentation index
+
+;; Note that `xref-index` returns a list of 30K+ `entry` structs. We
+;; can't avoid that with the official API. That will bump peak memory
+;; use. :( Best we can do is sandwich it in major GCs, to avoid the
+;; peak going even higher. Furthermore in doc-index-names we avoid
+;; making _another_ 30K+ list, by returning a thunk for elisp-write
+;; to call, to do "streaming" writes.
+
+(define ((doc-index-names))
+ (with-less-memory-pressure
+ (with-parens
+ (define xref (force xref-promise))
+ (for* ([entry (in-list (xref-index xref))]
+ [desc (in-value (entry-desc entry))]
+ #:when (not (constructor-index-desc? desc))
+ [term (in-value (car (entry-words entry)))])
+ (elisp-write term))
+ (newline))))
+
+(define (doc-index-lookup str)
+ (with-less-memory-pressure
+ (define xref (force xref-promise))
+ (define results
+ (for*/set ([entry (in-list (xref-index xref))]
+ [desc (in-value (entry-desc entry))]
+ #:when (not (constructor-index-desc? desc))
+ [term (in-value (car (entry-words entry)))]
+ #:when (equal? str term))
+ (define tag (entry-tag entry))
+ (define-values (path anchor) (xref-tag->path+anchor xref tag))
+ (define-values (what from)
+ (cond
+ [(module-path-index-desc? desc)
+ (values 'module null)]
+ [(exported-index-desc? desc)
+ (define kind
+ (match desc
+ [(? language-index-desc?) 'language]
+ [(? reader-index-desc?) 'reader]
+ [(? form-index-desc?) 'syntax]
+ [(? procedure-index-desc?) 'procedure]
+ [(? thing-index-desc?) 'value]
+ [(? struct-index-desc?) 'structure]
+ [(? class-index-desc?) 'class]
+ [(? interface-index-desc?) 'interface]
+ [(? mixin-index-desc?) 'mixin]
+ [(? method-index-desc?)
+ (cond
+ [(method-tag? tag)
+ (define-values (c/i _m) (get-class/interface-and-method tag))
+ (cons 'method c/i)]
+ [else 'method])]
+ [_ ""]))
+ (define libs (exported-index-desc-from-libs desc))
+ (values kind libs)]
+ [else
+ (println (reverse (explode-path path)))
+ (values 'documentation
+ (list
+ (match (reverse (explode-path path))
+ [(list* _ v _) (path->string v)]
+ [_ (~a tag)])))]))
+ (list term what from path anchor)))
+ (sort (set->list results)
+ string<?
+ #:cache-keys? #t
+ #:key
+ (match-lambda
+ [(list* _term _what (cons from _) _path _anchor)
+ (match (~a from)
+ [(and (pregexp "^racket/") v)
+ (string-append "0_" v)]
+ [(and (pregexp "^typed/racket/") v)
+ (string-append "1_" v)]
+ [v v])]
+ [(cons term _) term]))))
+
+;;; This is for the requires/find command
+
+;; Given some symbol as a string, return the modules providing it,
+;; sorted by most likely to be desired.
(define (libs-exporting-documented sym-as-str)
- ;; Take just the first lib. This usually seems to be the
- ;; most-specific, e.g. (racket/base racket).
- (map car
- ;; Take just the list of libs.
- (map car
- (libs+paths+anchors-exporting-documented sym-as-str))))
+ (with-less-memory-pressure
+ (define xref (force xref-promise))
+ (define results
+ (for*/set ([entry (in-list (xref-index xref))]
+ [desc (in-value (entry-desc entry))]
+ #:when (exported-index-desc? desc)
+ [name (in-value (symbol->string
+ (exported-index-desc-name desc)))]
+ #:when (equal? name sym-as-str)
+ [libs (in-value (map symbol->string
+ (exported-index-desc-from-libs desc)))]
+ #:when (not (null? libs)))
+ ;; Take just the first lib. This usually seems to be the
+ ;; most-specific, e.g. (racket/base racket).
+ (car libs)))
+ (sort (set->list results)
+ string<?
+ #:cache-keys? #t
+ #:key
+ (lambda (lib)
+ (match lib
+ [(and (pregexp "^racket/") v)
+ (string-append "0_" v)]
+ [(and (pregexp "^typed/racket/") v)
+ (string-append "1_" v)]
+ [v v])))))
diff --git a/racket/stack-checkpoint.rkt b/racket/stack-checkpoint.rkt
index 1d854be..f94bb1d 100644
--- a/racket/stack-checkpoint.rkt
+++ b/racket/stack-checkpoint.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require racket/list
diff --git a/racket/syntax.rkt b/racket/syntax.rkt
index bdd7b54..683586f 100644
--- a/racket/syntax.rkt
+++ b/racket/syntax.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require (only-in openssl/md5 md5)
@@ -6,10 +9,9 @@
racket/match
(only-in racket/path path-only)
syntax/modread
- syntax/parse/define
"online-check-syntax.rkt")
-(provide with-expanded-syntax-caching-evaluator
+(provide make-caching-load/use-compiled-handler
file->syntax
file->expanded-syntax
string->expanded-syntax
@@ -56,30 +58,10 @@
;;; Expanded syntax caching
-(define (call-with-expanded-syntax-caching-evaluator thk)
- (parameterize ([current-eval (make-eval-handler)])
- (thk)))
-
-(define-simple-macro (with-expanded-syntax-caching-evaluator e:expr ...+)
- (call-with-expanded-syntax-caching-evaluator (λ () e ...)))
-
-(define ((make-eval-handler [orig-eval (current-eval)]) e)
- (cond [(and (syntax? e)
- (not (compiled-expression? (syntax-e e)))
- (syntax-source e)
- (path-string? (syntax-source e))
- (complete-path? (syntax-source e))
- (file-exists? (syntax-source e)))
- (define expanded-stx (expand e))
- (define-values (code-str digest) (file->string+digest (syntax-source e)))
- (cache-set! (syntax-source e) code-str e expanded-stx digest)
- (orig-eval expanded-stx)]
- [else (orig-eval e)]))
-
-(define (->path v)
- (cond [(path? v) v]
- [(path-string? v) (string->path v)]
- [else (error '->path "not path? or path-string?" v)]))
+;; Various functions to obtain syntax or fully-expanded syntax from
+;; files or strings, backed by a cache, as well as a compiled load
+;; handler that warms the cache. Note: The cache stores expansions
+;; from expand ("enriched") -- /not/ from expand-syntax.
;; Returns the result of applying `k` to the expanded syntax, with the
;; correct parameterization of current-namespace and
@@ -188,6 +170,31 @@
(log-racket-mode-syntax-cache-warning "path->existing-expanded-syntax cache MISS ~v (ignoring digest); no code string cached for path, cannot re-expand" path)
#f])]))
+;; Compiled load handler: This is an optimization to warm the cache
+;; with expansions done for loads that need to compile, including
+;; imports that need to compile. Can speed up scenarios like visiting
+;; a definition in a required file.
+(define (make-caching-load/use-compiled-handler)
+ (define old-handler (current-load/use-compiled))
+ (define old-compile (current-compile))
+ (define (new-compile stx immediate?)
+ (match (syntax-source stx)
+ [(? path? file)
+ (define exp-stx (expand stx))
+ (define-values (code-str digest) (file->string+digest file))
+ (cache-set! file code-str stx exp-stx digest)
+ (old-compile exp-stx immediate?)]
+ [_ (old-compile stx immediate?)]))
+ (define (new-handler file mod)
+ (parameterize ([current-compile new-compile])
+ (old-handler file mod)))
+ new-handler)
+
+(define (->path v)
+ (cond [(path? v) v]
+ [(path-string? v) (string->path v)]
+ [else (error '->path "not path? or path-string?" v)]))
+
(define/contract (file->digest path)
(-> path? string?)
(call-with-input-file path md5))
diff --git a/racket/util.rkt b/racket/util.rkt
index c8b47e6..d9ac05d 100644
--- a/racket/util.rkt
+++ b/racket/util.rkt
@@ -1,3 +1,6 @@
+;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
#lang racket/base
(require (for-syntax racket/base)
@@ -90,7 +93,7 @@
(define (time-apply/log what proc args)
(define-values (vs cpu real gc) (time-apply proc args))
(define (fmt n) (~v #:align 'right #:min-width 4 n))
- (log-racket-mode-debug "~a cpu | ~a real | ~a gc <= ~a"
+ (log-racket-mode-debug "~a cpu | ~a real | ~a gc :: ~a"
(fmt cpu) (fmt real) (fmt gc) what)
(apply values vs))
diff --git a/test/example/class-internal.rkt b/test/example/class-internal.rkt
new file mode 100644
index 0000000..d117d41
--- /dev/null
+++ b/test/example/class-internal.rkt
@@ -0,0 +1,4939 @@
+#lang racket/base
+(require (for-syntax racket/base)
+ (only-in racket/list remove-duplicates)
+ racket/stxparam
+ racket/unsafe/ops
+ "serialize-structs.rkt"
+ "class-wrapped.rkt"
+ racket/runtime-path
+ (only-in "../contract/region.rkt" current-contract-region)
+ "../contract/base.rkt"
+ "../contract/combinator.rkt"
+ racket/unsafe/undefined
+ "class-undef.rkt"
+ (for-syntax racket/stxparam
+ racket/private/immediate-default
+ syntax/kerncase
+ syntax/stx
+ syntax/name
+ syntax/define
+ syntax/flatten-begin
+ syntax/private/boundmap
+ syntax/parse
+ "classidmap.rkt"
+ "intdef-util.rkt"))
+
+(define insp (current-inspector)) ; for all opaque structures
+
+;;--------------------------------------------------------------------
+;; spec for external interface
+;;--------------------------------------------------------------------
+
+(provide provide-public-names
+ ;; needed for Typed Racket
+ (protect-out do-make-object find-method/who))
+(define-syntax (provide-public-names stx)
+ (class-syntax-protect
+ (datum->syntax
+ stx
+ '(provide class class* class/derived
+ define-serializable-class define-serializable-class*
+ class?
+ mixin
+ interface interface* interface?
+ object% object? externalizable<%> printable<%> writable<%> equal<%>
+ object=? object-or-false=? object=-hash-code
+ new make-object instantiate
+ send send/apply send/keyword-apply send* send+ dynamic-send
+ class-field-accessor class-field-mutator with-method
+ get-field set-field! field-bound? field-names
+ dynamic-get-field dynamic-set-field!
+ private* public* pubment*
+ override* overment*
+ augride* augment*
+ public-final* override-final* augment-final*
+ define/private define/public define/pubment
+ define/override define/overment
+ define/augride define/augment
+ define/public-final define/override-final define/augment-final
+ define-local-member-name define-member-name
+ member-name-key generate-member-key
+ member-name-key? member-name-key=? member-name-key-hash-code
+ generic make-generic send-generic
+ is-a? subclass? implementation? interface-extension?
+ object-interface object-info object->vector
+ object-method-arity-includes?
+ method-in-interface? interface->method-names class->interface class-info
+ (struct-out exn:fail:object)
+ make-primitive-class
+ class/c ->m ->*m ->dm case->m object/c instanceof/c
+ dynamic-object/c
+ class-seal class-unseal
+
+ ;; "keywords":
+ private public override augment
+ pubment overment augride
+ public-final override-final augment-final
+ field init init-field init-rest
+ rename-super rename-inner inherit inherit/super inherit/inner inherit-field
+ this this% super inner
+ super-make-object super-instantiate super-new
+ inspect absent abstract)
+ stx)))
+
+;;--------------------------------------------------------------------
+;; keyword setup
+;;--------------------------------------------------------------------
+
+(define-for-syntax (do-class-keyword stx orig-sym)
+ (let ([orig-stx (datum->syntax #f orig-sym stx)])
+ (if (identifier? stx)
+ (raise-syntax-error
+ #f
+ "illegal (unparenthesized) use of a class keyword"
+ orig-stx)
+ (raise-syntax-error
+ #f
+ "use of a class keyword is not in a class top-level"
+ orig-stx))))
+
+(define-for-syntax (rewrite-renaming-class-keyword stx internal-id)
+ (syntax-case stx ()
+ [(_ elem ...)
+ ;; Set taint mode on elem ...
+ (with-syntax ([internal-id internal-id]
+ [(elem ...) (for/list ([e (in-list (syntax->list #'(elem ...)))])
+ (if (identifier? e)
+ e
+ (syntax-property e 'taint-mode 'transparent)))])
+ (class-syntax-protect
+ (syntax-property (syntax/loc stx (internal-id elem ...))
+ 'taint-mode
+ 'transparent)))]))
+
+(define-syntax provide-renaming-class-keyword
+ (syntax-rules ()
+ [(_ [id internal-id] ...)
+ (begin
+ (define-syntax (id stx) (rewrite-renaming-class-keyword stx #'internal-id))
+ ...
+ (define-syntax (internal-id stx) (do-class-keyword stx 'id))
+ ...
+ (provide id ...))]))
+
+(provide-renaming-class-keyword [private -private]
+ [public -public]
+ [override -override]
+ [augride -augride]
+ [pubment -pubment]
+ [overment -overment]
+ [augment -augment]
+ [public-final -public-final]
+ [override-final -override-final]
+ [augment-final -augment-final]
+ [rename-super -rename-super]
+ [rename-inner -rename-inner]
+ [inherit -inherit]
+ [inherit-field -inherit-field]
+ [inherit/super -inherit/super]
+ [inherit/inner -inherit/inner]
+ [abstract -abstract])
+
+(define-for-syntax (rewrite-naming-class-keyword stx internal-id)
+ (syntax-case stx ()
+ [(_ elem ...)
+ (with-syntax ([internal-id internal-id])
+ (class-syntax-protect
+ (syntax-property (syntax/loc stx (internal-id elem ...))
+ 'taint-mode
+ 'transparent)))]))
+
+(define-syntax provide-naming-class-keyword
+ (syntax-rules ()
+ [(_ [id internal-id] ...)
+ (begin
+ (define-syntax (id stx) (rewrite-naming-class-keyword stx #'internal-id))
+ ...
+ (define-syntax (internal-id stx) (do-class-keyword stx 'id))
+ ...
+ (provide id ...))]))
+
+(provide-naming-class-keyword [inspect -inspect]
+ [init-rest -init-rest])
+
+;; Going ahead and doing this in a generic fashion, in case we later realize that
+;; we need more class contract-specific keywords.
+(define-for-syntax (do-class-contract-keyword stx)
+ (raise-syntax-error
+ #f
+ "use of a class contract keyword is not in a class contract"
+ stx))
+
+(define-syntax provide-class-contract-keyword
+ (syntax-rules ()
+ [(_ id ...)
+ (begin
+ (define-syntax (id stx) (do-class-contract-keyword stx))
+ ...
+ (provide id ...))]))
+
+(provide-class-contract-keyword absent)
+
+(define-for-syntax (do-define-like-internal stx)
+ (syntax-case stx ()
+ [(_ orig . __)
+ (raise-syntax-error
+ #f
+ "use of a class keyword is not in a class top-level"
+ #'orig)]))
+
+(define-for-syntax (do-define-like stx internal-id)
+ (syntax-case stx ()
+ [(_ elem ...)
+ (syntax-property
+ #`(#,internal-id #,stx
+ #,@(map (lambda (e)
+ (if (identifier? e)
+ e
+ (syntax-property
+ (syntax-case e ()
+ [((n1 n2) . expr)
+ (syntax-property
+ (quasisyntax/loc e
+ (#,(syntax-property
+ #'(n1 n2)
+ 'certify-mode 'transparent)
+ . expr))
+ 'certify-mode 'transparent)]
+ [(n . expr)
+ (identifier? #'n)
+ (syntax-property e 'certify-mode 'transparent)]
+ [_else e])
+ 'certify-mode 'transparent)))
+ (syntax-e #'(elem ...))))
+ 'certify-mode
+ 'transparent)]
+ [(_ . elems)
+ #`(#,internal-id #,stx . elems)]
+ [_else
+ (raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)]))
+
+(define-syntax provide-class-define-like-keyword
+ (syntax-rules ()
+ [(_ [internal-id id] ...)
+ (begin
+ (define-syntax (internal-id stx) (do-define-like-internal stx))
+ ...
+ (define-syntax (id stx) (do-define-like stx #'internal-id))
+ ...
+ (provide id ...))]))
+
+(provide-class-define-like-keyword
+ [-field field]
+ [-init init]
+ [-init-field init-field])
+
+
+(define-for-syntax not-in-a-class
+ (lambda (stx)
+ (if (eq? (syntax-local-context) 'expression)
+ (raise-syntax-error
+ #f
+ "use of a class keyword is not in a class"
+ stx)
+ (quasisyntax/loc stx (#%expression #,stx)))))
+
+(define-syntax define/provide-context-keyword
+ (syntax-rules ()
+ [(_ (id param-id) ...)
+ (begin
+ (begin
+ (provide id)
+ (define-syntax-parameter param-id
+ (make-set!-transformer not-in-a-class))
+ (define-syntax id
+ (make-parameter-rename-transformer #'param-id)))
+ ...)]))
+
+(define/provide-context-keyword
+ [this this-param]
+ [this% this%-param]
+ [super super-param]
+ [inner inner-param]
+ [super-make-object super-make-object-param]
+ [super-instantiate super-instantiate-param]
+ [super-new super-new-param])
+
+;;--------------------------------------------------------------------
+;; local member name lookup
+;;--------------------------------------------------------------------
+
+(define-for-syntax (localize orig-id)
+ (do-localize orig-id #'validate-local-member))
+
+(define (validate-local-member orig s)
+ (if (symbol? s)
+ s
+ (obj-error 'local-member-name
+ "used before its definition"
+ "name" (as-write orig))))
+
+;;--------------------------------------------------------------------
+;; field info creation/access
+;;--------------------------------------------------------------------
+
+;; A field-info is a (vector iref iset eref eset)
+;; where
+;; iref, iset, eref, and eset are projections to be applied
+;; on internal and external access and mutation.
+
+;; make-field-info creates a new field-info for a field.
+;; The caller gives the class and relative position (in the
+;; new object struct layer), and this function fills
+;; in the projections.
+(define (make-field-info cls rpos)
+ (let ([field-ref (make-struct-field-accessor (class-field-ref cls) rpos)]
+ [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)])
+ (vector field-ref field-set! field-ref field-set!)))
+
+(define (field-info-extend-internal fi ppos pneg neg-party)
+ (let* ([old-ref (unsafe-vector-ref fi 0)]
+ [old-set! (unsafe-vector-ref fi 1)])
+ (vector (λ (o) (ppos (old-ref o) neg-party))
+ (λ (o v) (old-set! o (pneg v neg-party)))
+ (unsafe-vector-ref fi 2)
+ (unsafe-vector-ref fi 3))))
+
+(define (field-info-extend-external fi ppos pneg neg-party)
+ (let* ([old-ref (unsafe-vector-ref fi 2)]
+ [old-set! (unsafe-vector-ref fi 3)])
+ (vector (unsafe-vector-ref fi 0)
+ (unsafe-vector-ref fi 1)
+ (λ (o) (ppos (old-ref o) neg-party))
+ (λ (o v) (old-set! o (pneg v neg-party))))))
+
+(define (field-info-internal-ref fi) (unsafe-vector-ref fi 0))
+(define (field-info-internal-set! fi) (unsafe-vector-ref fi 1))
+(define (field-info-external-ref fi) (unsafe-vector-ref fi 2))
+(define (field-info-external-set! fi) (unsafe-vector-ref fi 3))
+
+;;--------------------------------------------------------------------
+;; class macros
+;;--------------------------------------------------------------------
+
+(define-syntaxes (class* _class class/derived)
+ (let ()
+ ;; Start with Helper functions
+
+ (define (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)
+ (let* ([stop-forms
+ (append
+ (kernel-form-identifier-list)
+ (list
+ (quote-syntax #%app) ; racket/base app, as opposed to #%plain-app
+ (quote-syntax lambda) ; racket/base lambda, as opposed to #%plain-lambda
+ (quote-syntax -init)
+ (quote-syntax -init-rest)
+ (quote-syntax -field)
+ (quote-syntax -init-field)
+ (quote-syntax -inherit-field)
+ (quote-syntax -private)
+ (quote-syntax -public)
+ (quote-syntax -override)
+ (quote-syntax -augride)
+ (quote-syntax -public-final)
+ (quote-syntax -override-final)
+ (quote-syntax -augment-final)
+ (quote-syntax -pubment)
+ (quote-syntax -overment)
+ (quote-syntax -augment)
+ (quote-syntax -rename-super)
+ (quote-syntax -inherit)
+ (quote-syntax -inherit/super)
+ (quote-syntax -inherit/inner)
+ (quote-syntax -rename-inner)
+ (quote-syntax -abstract)
+ (quote-syntax super)
+ (quote-syntax inner)
+ (quote-syntax this)
+ (quote-syntax this%)
+ (quote-syntax super-instantiate)
+ (quote-syntax super-make-object)
+ (quote-syntax super-new)
+ (quote-syntax -inspect)))]
+ [expand-context (generate-class-expand-context)]
+ [expand
+ (lambda (defn-or-expr)
+ (local-expand
+ defn-or-expr
+ expand-context
+ stop-forms
+ def-ctx))])
+ (let loop ([l defn-and-exprs])
+ (if (null? l)
+ null
+ (let ([e (expand (car l))])
+ (define (copy-prop stx . ps) (for/fold ([stx stx])
+ ([p ps])
+ (syntax-property stx p (syntax-property e p))))
+ (syntax-case e (begin define-syntaxes define-values)
+ [(begin . _)
+ (loop (append
+ (flatten-begin e)
+ (cdr l)))]
+ [(define-syntaxes (id ...) rhs)
+ (andmap identifier? (syntax->list #'(id ...)))
+ (begin
+ (with-syntax ([rhs (local-transformer-expand
+ #'rhs
+ 'expression
+ null)])
+ (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
+ (with-syntax ([(id ...) (map syntax-local-identifier-as-binding
+ (syntax->list #'(id ...)))])
+ (cons (copy-prop (syntax/loc e (define-syntaxes (id ...) rhs))
+ 'disappeared-use 'origin 'disappeared-binding)
+ (loop (cdr l))))))]
+ [(define-values (id ...) rhs)
+ (andmap identifier? (syntax->list #'(id ...)))
+ (let ([ids (map bind-local-id (syntax->list #'(id ...)))])
+ (with-syntax ([(id ...) ids])
+ (cons (datum->syntax e (list #'define-values #'(id ...) #'rhs) e e)
+ (loop (cdr l)))))]
+ [_else
+ (cons e (loop (cdr l)))]))))))
+
+ ;; returns two lists: expressions that start with an identifier in
+ ;; `kws', and expressions that don't
+ (define (extract kws l out-cons)
+ (let loop ([l l])
+ (if (null? l)
+ (values null null)
+ (let-values ([(in out) (loop (cdr l))])
+ (cond
+ [(and (stx-pair? (car l))
+ (let ([id (stx-car (car l))])
+ (and (identifier? id)
+ (ormap (lambda (k) (free-identifier=? k id)) kws))))
+ (values (cons (car l) in) out)]
+ [else
+ (values in (out-cons (car l) out))])))))
+
+ (define (extract* kws l)
+ (let-values ([(in out) (extract kws l void)])
+ in))
+
+ (define (flatten alone l)
+ (apply append
+ (map (lambda (i)
+ (let ([l (let ([l (syntax->list i)])
+ (if (ormap (lambda (i)
+ (free-identifier=? (car l) i))
+ (syntax-e (quote-syntax (-init -init-field -field))))
+ (cddr l)
+ (cdr l)))])
+ (if alone
+ (map (lambda (i)
+ (if (identifier? i)
+ (alone (syntax-local-identifier-as-binding i))
+ (cons (syntax-local-identifier-as-binding (stx-car i))
+ (syntax-local-identifier-as-binding (stx-car (stx-cdr i))))))
+ l)
+ l)))
+ l)))
+
+ ;; Used with flatten:
+ (define (pair i) (cons i i))
+
+ (define (normalize-init/field i)
+ ;; Put i in ((iid eid) optional-expr) form
+ (cond
+ [(identifier? i) (list (list i i))]
+ [else (let ([a (stx-car i)])
+ (if (identifier? a)
+ (cons (list a a) (stx-cdr i))
+ i))]))
+
+ (define (norm-init/field-iid norm) (syntax-local-identifier-as-binding (stx-car (stx-car norm))))
+ (define (norm-init/field-eid norm) (syntax-local-identifier-as-binding (stx-car (stx-cdr (stx-car norm)))))
+
+ ;; expands an expression enough that we can check whether it has
+ ;; the right form for a method; must use local syntax definitions
+ (define (proc-shape name orig-stx xform?
+ the-obj the-finder
+ bad class-name expand-stop-names
+ def-ctx lookup-localize)
+ (define (expand expr locals)
+ (local-expand
+ expr
+ 'expression
+ (append locals (list #'lambda #'λ) expand-stop-names)
+ def-ctx))
+ ;; Checks whether the vars sequence is well-formed
+ (define (vars-ok? vars)
+ (or (identifier? vars)
+ (stx-null? vars)
+ (and (stx-pair? vars)
+ (identifier? (stx-car vars))
+ (vars-ok? (stx-cdr vars)))))
+ (define (kw-vars-ok? vars)
+ (or (identifier? vars)
+ (stx-null? vars)
+ (and (stx-pair? vars)
+ (let ([a (stx-car vars)]
+ [opt-arg-ok?
+ (lambda (a)
+ (or (identifier? a)
+ (and (stx-pair? a)
+ (identifier? (stx-car a))
+ (stx-pair? (stx-cdr a))
+ (stx-null? (stx-cdr (stx-cdr a))))))])
+ (or (and (opt-arg-ok? a)
+ (kw-vars-ok? (stx-cdr vars)))
+ (and (keyword? (syntax-e a))
+ (stx-pair? (stx-cdr vars))
+ (opt-arg-ok? (stx-car (stx-cdr vars)))
+ (kw-vars-ok? (stx-cdr (stx-cdr vars)))))))))
+ ;; mk-name: constructs a method name
+ ;; for error reporting, etc.
+ (define (mk-name name)
+ (datum->syntax
+ #f
+ (string->symbol (format "~a method~a~a"
+ (syntax-e name)
+ (if class-name
+ " in "
+ "")
+ (or class-name
+ "")))
+ #f))
+ ;; -- transform loop starts here --
+ (let loop ([stx orig-stx][can-expand? #t][name name][locals null])
+ (syntax-case (disarm stx) (#%plain-lambda lambda λ case-lambda letrec-values let-values)
+ [(lam vars body1 body ...)
+ (or (and (free-identifier=? #'lam #'#%plain-lambda)
+ (vars-ok? (syntax vars)))
+ (and (or (free-identifier=? #'lam #'lambda)
+ (free-identifier=? #'lam #'λ))
+ (kw-vars-ok? (syntax vars))))
+ (if xform?
+ (with-syntax ([the-obj the-obj]
+ [the-finder the-finder]
+ [name (mk-name name)])
+ (with-syntax ([vars (if (or (free-identifier=? #'lam #'lambda)
+ (free-identifier=? #'lam #'λ))
+ (let loop ([vars #'vars])
+ (cond
+ [(identifier? vars) vars]
+ [(syntax? vars)
+ (datum->syntax vars
+ (loop (syntax-e vars))
+ vars
+ vars)]
+ [(pair? vars)
+ (syntax-case (car vars) ()
+ [(id expr)
+ (and (identifier? #'id) (not (immediate-default? #'expr)))
+ ;; optional argument; need to wrap arg expression
+ (cons
+ (with-syntax ([expr (syntax/loc #'expr
+ (syntax-parameterize ([the-finder (quote-syntax the-obj)])
+ (#%expression expr)))])
+ (syntax/loc (car vars)
+ (id expr)))
+ (loop (cdr vars)))]
+ [_ (cons (car vars) (loop (cdr vars)))])]
+ [else vars]))
+ #'vars)])
+ (let ([l (syntax/loc stx
+ (lambda (the-obj . vars)
+ (syntax-parameterize ([the-finder (quote-syntax the-obj)])
+ body1 body ...)))])
+ (syntax-track-origin
+ (with-syntax ([l (rearm (add-method-property l) stx)])
+ (syntax/loc stx
+ (let ([name l]) name)))
+ stx
+ (syntax-local-introduce #'lam)))))
+ stx)]
+ [(#%plain-lambda . _)
+ (bad "ill-formed lambda expression for method" stx)]
+ [(lambda . _)
+ (bad "ill-formed lambda expression for method" stx)]
+ [(λ . _)
+ (bad "ill-formed lambda expression for method" stx)]
+ [(case-lam [vars body1 body ...] ...)
+ (and (free-identifier=? #'case-lam #'case-lambda)
+ (andmap vars-ok? (syntax->list (syntax (vars ...)))))
+ (if xform?
+ (with-syntax ([the-obj the-obj]
+ [the-finder the-finder]
+ [name (mk-name name)])
+ (let ([cl (syntax/loc stx
+ (case-lambda [(the-obj . vars)
+ (syntax-parameterize ([the-finder (quote-syntax the-obj)])
+ body1 body ...)] ...))])
+ (syntax-track-origin
+ (with-syntax ([cl (rearm (add-method-property cl) stx)])
+ (syntax/loc stx
+ (let ([name cl]) name)))
+ stx
+ (syntax-local-introduce #'case-lam))))
+ stx)]
+ [(case-lambda . _)
+ (bad "ill-formed case-lambda expression for method" stx)]
+ [(let- ([(id) expr] ...) let-body)
+ (and (or (free-identifier=? (syntax let-)
+ (quote-syntax let-values))
+ (free-identifier=? (syntax let-)
+ (quote-syntax letrec-values)))
+ (andmap identifier? (syntax->list (syntax (id ...)))))
+ (let* ([letrec? (free-identifier=? (syntax let-)
+ (quote-syntax letrec-values))]
+ [ids (syntax->list (syntax (id ...)))]
+ [new-ids (if xform?
+ (map
+ (lambda (id)
+ (datum->syntax
+ #f
+ (gensym (syntax-e id))))
+ ids)
+ ids)]
+ [body-locals (append ids locals)]
+ [exprs (map (lambda (expr id)
+ (loop expr #t id (if letrec?
+ body-locals
+ locals)))
+ (syntax->list (syntax (expr ...)))
+ ids)]
+ [body (let ([body (syntax let-body)])
+ (if (identifier? body)
+ (ormap (lambda (id new-id)
+ (and (bound-identifier=? body id)
+ new-id))
+ ids new-ids)
+ (loop body #t name body-locals)))])
+ (unless body
+ (bad "bad form for method definition" orig-stx))
+ (with-syntax ([(proc ...) exprs]
+ [(new-id ...) new-ids]
+ [mappings
+ (if xform?
+ (map
+ (lambda (old-id new-id)
+ (with-syntax ([old-id old-id]
+ [old-id-localized (lookup-localize (localize old-id))]
+ [new-id new-id]
+ [the-obj the-obj]
+ [the-finder the-finder])
+ (syntax (old-id (make-direct-method-map
+ (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax old-id)
+ (quote-syntax old-id-localized)
+ (quote new-id))))))
+ ids new-ids)
+ null)]
+ [body body])
+ (syntax-track-origin
+ (rearm
+ (if xform?
+ (if letrec?
+ (syntax/loc stx (letrec-syntax mappings
+ (let- ([(new-id) proc] ...)
+ body)))
+ (syntax/loc stx (let- ([(new-id) proc] ...)
+ (letrec-syntax mappings
+ body))))
+ (syntax/loc stx (let- ([(new-id) proc] ...)
+ body)))
+ stx)
+ stx
+ (syntax-local-introduce #'let-))))]
+ [(-#%app -chaperone-procedure expr . rst)
+ (and (free-identifier=? (syntax -#%app)
+ (quote-syntax #%plain-app))
+ (free-identifier=? (syntax -chaperone-procedure)
+ (quote-syntax chaperone-procedure)))
+ (with-syntax ([expr (loop #'expr #t name locals)])
+ (syntax-track-origin
+ (rearm
+ (syntax/loc stx (-#%app -chaperone-procedure expr . rst))
+ stx)
+ stx
+ (syntax-local-introduce #'-#%app)))]
+ [_else
+ (if can-expand?
+ (loop (expand stx locals) #f name locals)
+ (bad "bad form for method definition" orig-stx))])))
+
+ (define (add-method-property l)
+ (syntax-property l 'method-arity-error #t))
+
+ ;; `class' wants to be priviledged with respect to
+ ;; syntax taints: save the declaration-time inspector and use it
+ ;; to disarm syntax taints
+ (define method-insp (variable-reference->module-declaration-inspector
+ (#%variable-reference)))
+ (define (disarm stx)
+ (syntax-disarm stx method-insp))
+ (define (rearm new old)
+ (syntax-rearm new old))
+
+ ;; --------------------------------------------------------------------------------
+ ;; Start here:
+
+ (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
+ (let-values ([(this-id) #'this-id]
+ [(the-obj) (datum->syntax (quote-syntax here) (gensym 'self))]
+ [(the-finder) (datum->syntax #f (gensym 'find-self))])
+
+ (let* ([def-ctx (syntax-local-make-definition-context)]
+ [localized-map (make-bound-identifier-mapping)]
+ [any-localized? #f]
+ [localize/set-flag (lambda (id)
+ (let ([id2 (localize id)])
+ (unless (eq? id id2)
+ (set! any-localized? #t))
+ id2))]
+ [bind-local-id (lambda (orig-id)
+ (let ([l (localize/set-flag orig-id)]
+ [id (syntax-local-identifier-as-binding orig-id)])
+ (syntax-local-bind-syntaxes (list id) #f def-ctx)
+ (bound-identifier-mapping-put!
+ localized-map
+ id
+ l)
+ id))]
+ [lookup-localize (lambda (id)
+ (bound-identifier-mapping-get
+ localized-map
+ id
+ (lambda ()
+ ;; If internal & external names are distinguished,
+ ;; we need to fall back to localize:
+ (localize id))))])
+
+ ;; ----- Expand definitions -----
+ (let ([defn-and-exprs (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)]
+ [bad (lambda (msg expr)
+ (raise-syntax-error #f msg stx expr))]
+ [class-name (if name-id
+ (syntax-e name-id)
+ (let ([s (syntax-local-infer-name stx)])
+ (if (syntax? s)
+ (syntax-e s)
+ s)))])
+
+ ;; ------ Basic syntax checks -----
+ (for-each (lambda (stx)
+ (syntax-case stx (-init -init-rest -field -init-field -inherit-field
+ -private -public -override -augride
+ -public-final -override-final -augment-final
+ -pubment -overment -augment
+ -rename-super -inherit -inherit/super -inherit/inner -rename-inner
+ -abstract
+ -inspect)
+ [(form orig idp ...)
+ (and (identifier? (syntax form))
+ (or (free-identifier=? (syntax form) (quote-syntax -init))
+ (free-identifier=? (syntax form) (quote-syntax -init-field))))
+
+ (let ([form (syntax-e (stx-car (syntax orig)))])
+ (for-each
+ (lambda (idp)
+ (syntax-case idp ()
+ [id (identifier? (syntax id)) 'ok]
+ [((iid eid)) (and (identifier? (syntax iid))
+ (identifier? (syntax eid))) 'ok]
+ [(id expr) (identifier? (syntax id)) 'ok]
+ [((iid eid) expr) (and (identifier? (syntax iid))
+ (identifier? (syntax eid))) 'ok]
+ [else
+ (bad
+ (format
+ "~a element is not an optionally renamed identifier or identifier-expression pair"
+ form)
+ idp)]))
+ (syntax->list (syntax (idp ...)))))]
+ [(-inspect expr)
+ 'ok]
+ [(-inspect . rest)
+ (bad "ill-formed inspect clause" stx)]
+ [(-init orig . rest)
+ (bad "ill-formed init clause" #'orig)]
+ [(-init-rest)
+ 'ok]
+ [(-init-rest rest)
+ (identifier? (syntax rest))
+ 'ok]
+ [(-init-rest . rest)
+ (bad "ill-formed init-rest clause" stx)]
+ [(-init-field orig . rest)
+ (bad "ill-formed init-field clause" #'orig)]
+ [(-field orig idp ...)
+ (for-each (lambda (idp)
+ (syntax-case idp ()
+ [(id expr) (identifier? (syntax id)) 'ok]
+ [((iid eid) expr) (and (identifier? (syntax iid))
+ (identifier? (syntax eid)))
+ 'ok]
+ [else
+ (bad
+ "field element is not an optionally renamed identifier-expression pair"
+ idp)]))
+ (syntax->list (syntax (idp ...))))]
+ [(-field orig . rest)
+ (bad "ill-formed field clause" #'orig)]
+ [(-private id ...)
+ (for-each
+ (lambda (id)
+ (unless (identifier? id)
+ (bad "private element is not an identifier" id)))
+ (syntax->list (syntax (id ...))))]
+ [(-private . rest)
+ (bad "ill-formed private clause" stx)]
+ [(-abstract id ...)
+ (for-each
+ (lambda (id)
+ (unless (identifier? id)
+ (bad "abstract element is not an identifier" id)))
+ (syntax->list (syntax (id ...))))]
+ [(-abstract . rest)
+ (bad "ill-formed abstract clause" stx)]
+ [(form idp ...)
+ (and (identifier? (syntax form))
+ (ormap (lambda (f) (free-identifier=? (syntax form) f))
+ (syntax-e (quote-syntax (-public
+ -override
+ -augride
+ -public-final
+ -override-final
+ -augment-final
+ -pubment
+ -overment
+ -augment
+ -inherit
+ -inherit/super
+ -inherit/inner
+ -inherit-field)))))
+ (let ([form (syntax-e (syntax form))])
+ (for-each
+ (lambda (idp)
+ (syntax-case idp ()
+ [id (identifier? (syntax id)) 'ok]
+ [(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
+ [else
+ (bad
+ (format
+ "~a element is not an identifier or pair of identifiers"
+ form)
+ idp)]))
+ (syntax->list (syntax (idp ...)))))]
+ [(-public . rest)
+ (bad "ill-formed public clause" stx)]
+ [(-override . rest)
+ (bad "ill-formed override clause" stx)]
+ [(-augride . rest)
+ (bad "ill-formed augride clause" stx)]
+ [(-public-final . rest)
+ (bad "ill-formed public-final clause" stx)]
+ [(-override-final . rest)
+ (bad "ill-formed override-final clause" stx)]
+ [(-augment-final . rest)
+ (bad "ill-formed augment-final clause" stx)]
+ [(-pubment . rest)
+ (bad "ill-formed pubment clause" stx)]
+ [(-overment . rest)
+ (bad "ill-formed overment clause" stx)]
+ [(-augment . rest)
+ (bad "ill-formed augment clause" stx)]
+ [(-inherit . rest)
+ (bad "ill-formed inherit clause" stx)]
+ [(-inherit/super . rest)
+ (bad "ill-formed inherit/super clause" stx)]
+ [(-inherit/inner . rest)
+ (bad "ill-formed inherit/inner clause" stx)]
+ [(-inherit-field . rest)
+ (bad "ill-formed inherit-field clause" stx)]
+ [(kw idp ...)
+ (and (identifier? #'kw)
+ (or (free-identifier=? #'-rename-super #'kw)
+ (free-identifier=? #'-rename-inner #'kw)))
+ (for-each
+ (lambda (idp)
+ (syntax-case idp ()
+ [(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
+ [else
+ (bad
+ (format "~a element is not a pair of identifiers" (syntax-e #'kw))
+ idp)]))
+ (syntax->list (syntax (idp ...))))]
+ [(-rename-super . rest)
+ (bad "ill-formed rename-super clause" stx)]
+ [(-rename-inner . rest)
+ (bad "ill-formed rename-inner clause" stx)]
+ [_ 'ok]))
+ defn-and-exprs)
+
+ ;; ----- Sort body into different categories -----
+ (let*-values ([(decls exprs)
+ (extract (syntax-e (quote-syntax (-inherit-field
+ -private
+ -public
+ -override
+ -augride
+ -public-final
+ -override-final
+ -augment-final
+ -pubment
+ -overment
+ -augment
+ -rename-super
+ -inherit
+ -inherit/super
+ -inherit/inner
+ -abstract
+ -rename-inner)))
+ defn-and-exprs
+ cons)]
+ [(inspect-decls exprs)
+ (extract (list (quote-syntax -inspect))
+ exprs
+ cons)]
+ [(plain-inits)
+ ;; Normalize after, but keep un-normal for error reporting
+ (flatten #f (extract* (syntax-e
+ (quote-syntax (-init -init-rest)))
+ exprs))]
+ [(normal-plain-inits) (map normalize-init/field plain-inits)]
+ [(init-rest-decls _)
+ (extract (list (quote-syntax -init-rest))
+ exprs
+ void)]
+ [(inits)
+ (flatten #f (extract* (syntax-e
+ (quote-syntax (-init -init-field)))
+ exprs))]
+ [(normal-inits)
+ (map normalize-init/field inits)]
+ [(plain-fields)
+ (flatten #f (extract* (list (quote-syntax -field)) exprs))]
+ [(normal-plain-fields)
+ (map normalize-init/field plain-fields)]
+ [(plain-init-fields)
+ (flatten #f (extract* (list (quote-syntax -init-field)) exprs))]
+ [(normal-plain-init-fields)
+ (map normalize-init/field plain-init-fields)]
+ [(inherit-fields)
+ (flatten pair (extract* (list (quote-syntax -inherit-field)) decls))]
+ [(privates)
+ (flatten pair (extract* (list (quote-syntax -private)) decls))]
+ [(publics)
+ (flatten pair (extract* (list (quote-syntax -public)) decls))]
+ [(overrides)
+ (flatten pair (extract* (list (quote-syntax -override)) decls))]
+ [(augrides)
+ (flatten pair (extract* (list (quote-syntax -augride)) decls))]
+ [(public-finals)
+ (flatten pair (extract* (list (quote-syntax -public-final)) decls))]
+ [(override-finals)
+ (flatten pair (extract* (list (quote-syntax -override-final)) decls))]
+ [(pubments)
+ (flatten pair (extract* (list (quote-syntax -pubment)) decls))]
+ [(overments)
+ (flatten pair (extract* (list (quote-syntax -overment)) decls))]
+ [(augments)
+ (flatten pair (extract* (list (quote-syntax -augment)) decls))]
+ [(augment-finals)
+ (flatten pair (extract* (list (quote-syntax -augment-final)) decls))]
+ [(rename-supers)
+ (flatten pair (extract* (list (quote-syntax -rename-super)) decls))]
+ [(inherits)
+ (flatten pair (extract* (list (quote-syntax -inherit)) decls))]
+ [(inherit/supers)
+ (flatten pair (extract* (list (quote-syntax -inherit/super)) decls))]
+ [(inherit/inners)
+ (flatten pair (extract* (list (quote-syntax -inherit/inner)) decls))]
+ [(abstracts)
+ (flatten pair (extract* (list (quote-syntax -abstract)) decls))]
+ [(rename-inners)
+ (flatten pair (extract* (list (quote-syntax -rename-inner)) decls))])
+
+
+ ;; At most one inspect:
+ (unless (or (null? inspect-decls)
+ (null? (cdr inspect-decls)))
+ (bad "multiple inspect clauses" (cadr inspect-decls)))
+
+ ;; At most one init-rest:
+ (unless (or (null? init-rest-decls)
+ (null? (cdr init-rest-decls)))
+ (bad "multiple init-rest clauses" (cadr init-rest-decls)))
+
+ ;; Make sure init-rest is last
+ (unless (null? init-rest-decls)
+ (let loop ([l exprs] [saw-rest? #f])
+ (unless (null? l)
+ (cond
+ [(and (stx-pair? (car l))
+ (identifier? (stx-car (car l))))
+ (let ([form (stx-car (car l))])
+ (cond
+ [(free-identifier=? #'-init-rest form)
+ (loop (cdr l) #t)]
+ [(not saw-rest?) (loop (cdr l) #f)]
+ [(free-identifier=? #'-init form)
+ (bad "init clause follows init-rest clause" (stx-car (stx-cdr (car l))))]
+ [(free-identifier=? #'-init-field form)
+ (bad "init-field clause follows init-rest clause" (stx-car (stx-cdr (car l))))]
+ [else (loop (cdr l) #t)]))]
+ [else (loop (cdr l) saw-rest?)]))))
+
+ ;; --- Check initialization on inits: ---
+ (let loop ([inits inits] [normal-inits normal-inits])
+ (unless (null? normal-inits)
+ (if (stx-null? (stx-cdr (car normal-inits)))
+ (loop (cdr inits)(cdr normal-inits))
+ (let loop ([inits (cdr inits)] [normal-inits (cdr normal-inits)])
+ (unless (null? inits)
+ (if (stx-null? (stx-cdr (car normal-inits)))
+ (bad "initializer without default follows an initializer with default"
+ (car inits))
+ (loop (cdr inits) (cdr normal-inits))))))))
+
+ ;; ----- Extract method definitions; check that they look like procs -----
+ ;; Optionally transform them, can expand even if not transforming.
+ (let* ([field-names (map norm-init/field-iid
+ (append normal-plain-fields normal-plain-init-fields))]
+ [inherit-field-names (map car inherit-fields)]
+ [plain-init-names (map norm-init/field-iid normal-plain-inits)]
+ [inherit-names (map car inherits)]
+ [inherit/super-names (map car inherit/supers)]
+ [inherit/inner-names (map car inherit/inners)]
+ [abstract-names (map car abstracts)]
+ [rename-super-names (map car rename-supers)]
+ [rename-inner-names (map car rename-inners)]
+ [local-public-dynamic-names (map car (append publics overrides augrides
+ overments augments
+ override-finals augment-finals
+ abstracts))]
+ [local-public-names (append (map car (append pubments public-finals))
+ local-public-dynamic-names)]
+ [local-method-names (append (map car privates) local-public-names)]
+ [expand-stop-names (append
+ local-method-names
+ field-names
+ inherit-field-names
+ plain-init-names
+ inherit-names
+ inherit/super-names
+ inherit/inner-names
+ rename-super-names
+ rename-inner-names
+ (kernel-form-identifier-list))])
+ ;; Do the extraction:
+ (let-values ([(methods ; (listof (cons id stx))
+ private-methods ; (listof (cons id stx))
+ exprs ; (listof stx)
+ stx-defines) ; (listof (cons (listof id) stx))
+ (let loop ([exprs exprs][ms null][pms null][es null][sd null])
+ (if (null? exprs)
+ (values (reverse ms) (reverse pms) (reverse es) (reverse sd))
+ (syntax-case (car exprs) (define-values define-syntaxes)
+ [(d-v (id ...) expr)
+ (free-identifier=? #'d-v #'define-values)
+ (let ([ids (syntax->list (syntax (id ...)))])
+ ;; Check form:
+ (for-each (lambda (id)
+ (unless (identifier? id)
+ (bad "not an identifier for definition" id)))
+ ids)
+ ;; method defn? (id in the list of privates/publics/overrides/augrides?)
+ (if (ormap (lambda (id)
+ (ormap (lambda (i) (bound-identifier=? i id))
+ local-method-names))
+ ids)
+ ;; Yes, it's a method:
+ (begin
+ (unless (null? (cdr ids))
+ (bad "each method variable needs its own definition"
+ (car exprs)))
+ (let ([expr
+ (syntax-track-origin
+ (proc-shape #f (syntax expr) #f
+ the-obj the-finder
+ bad class-name expand-stop-names
+ def-ctx lookup-localize)
+ (car exprs)
+ (syntax-local-introduce #'d-v))]
+ [public? (ormap (lambda (i)
+ (bound-identifier=? i (car ids)))
+ local-public-names)])
+ (loop (cdr exprs)
+ (if public?
+ (cons (cons (car ids) expr) ms)
+ ms)
+ (if public?
+ pms
+ (cons (cons (car ids) expr) pms))
+ es
+ sd)))
+ ;; Non-method defn:
+ (loop (cdr exprs) ms pms (cons (car exprs) es) sd)))]
+ [(define-values . _)
+ (bad "ill-formed definition" (car exprs))]
+ [(define-syntaxes (id ...) expr)
+ (let ([ids (syntax->list (syntax (id ...)))])
+ (for-each (lambda (id) (unless (identifier? id)
+ (bad "syntax name is not an identifier" id)))
+ ids)
+ (loop (cdr exprs) ms pms es (cons (cons ids (car exprs)) sd)))]
+ [(define-syntaxes . _)
+ (bad "ill-formed syntax definition" (car exprs))]
+ [_else
+ (loop (cdr exprs) ms pms (cons (car exprs) es) sd)])))])
+
+ ;; ---- Extract all defined names, including field accessors and mutators ---
+ (let ([defined-syntax-names (apply append (map car stx-defines))]
+ [defined-method-names (append (map car methods)
+ (map car private-methods))]
+ [private-field-names (let loop ([l exprs])
+ (if (null? l)
+ null
+ (syntax-case (car l) (define-values)
+ [(define-values (id ...) expr)
+ (append (syntax->list (syntax (id ...)))
+ (loop (cdr l)))]
+ [_else (loop (cdr l))])))]
+ [init-mode (cond
+ [(null? init-rest-decls) 'normal]
+ [(stx-null? (stx-cdr (car init-rest-decls))) 'stop]
+ [else 'list])])
+
+ ;; -- Look for duplicates --
+ (let ([dup (check-duplicate-identifier
+ (append defined-syntax-names
+ defined-method-names
+ private-field-names
+ field-names
+ inherit-field-names
+ plain-init-names
+ inherit-names
+ inherit/super-names
+ inherit/inner-names
+ rename-super-names
+ rename-inner-names))])
+ (when dup
+ (bad "duplicate declared identifier" dup)))
+
+ ;; -- Could still have duplicates within private/public/override/augride --
+ (let ([dup (check-duplicate-identifier local-method-names)])
+ (when dup
+ (bad "duplicate declared identifier" dup)))
+
+ ;; -- Check for duplicate external method names, init names, or field names
+ (let ([check-dup
+ (lambda (what l)
+ (let ([ht (make-hasheq)])
+ (for-each (lambda (id)
+ (define key (let ([l-id (lookup-localize id)])
+ (if (identifier? l-id)
+ (syntax-e l-id)
+ ;; For a given localized id, `lookup-localize`
+ ;; will return the same (eq?) value
+ l-id)))
+ (when (hash-ref ht key #f)
+ (bad (format "duplicate declared external ~a name" what) id))
+ (hash-set! ht key #t))
+ l)))])
+ ;; method names
+ (check-dup "method" (map cdr (append publics overrides augrides
+ pubments overments augments
+ public-finals override-finals augment-finals)))
+ ;; inits
+ (check-dup "init" (map norm-init/field-eid (append normal-inits)))
+ ;; fields
+ (check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields))))
+
+ ;; -- Check that private/public/override/augride are defined --
+ ;; -- and that abstracts are *not* defined --
+ (let ([ht (make-hasheq)]
+ [stx-ht (make-hasheq)])
+ (for-each
+ (lambda (defined-name)
+ (let ([l (hash-ref ht (syntax-e defined-name) null)])
+ (hash-set! ht (syntax-e defined-name) (cons defined-name l))))
+ defined-method-names)
+ (for-each
+ (lambda (defined-name)
+ (let ([l (hash-ref stx-ht (syntax-e defined-name) null)])
+ (hash-set! stx-ht (syntax-e defined-name) (cons defined-name l))))
+ defined-syntax-names)
+ (for-each
+ (lambda (pubovr-name)
+ (let ([l (hash-ref ht (syntax-e pubovr-name) null)]
+ [stx-l (hash-ref stx-ht (syntax-e pubovr-name) null)])
+ (cond ;; defined as value
+ [(ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
+ ;; check if abstract and fail if so
+ (when (memq pubovr-name abstract-names)
+ (bad "method declared as abstract but was defined"
+ pubovr-name))]
+ ;; defined as syntax
+ [(ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
+ (bad "method declared but defined as syntax"
+ pubovr-name)]
+ ;; undefined
+ [else
+ (unless (memq pubovr-name abstract-names)
+ (bad "method declared as concrete but not defined"
+ pubovr-name))])))
+ local-method-names))
+
+ ;; ---- Check that rename-inner doesn't have a non-final decl ---
+ (unless (null? rename-inners)
+ (let ([ht (make-hasheq)])
+ (for-each (lambda (pub)
+ (hash-set! ht (syntax-e (cdr pub)) #t))
+ (append publics public-finals overrides override-finals augrides))
+ (for-each (lambda (inn)
+ (when (hash-ref ht (syntax-e (cdr inn)) #f)
+ (bad
+ "inner method is locally declared as public, override, public-final, override-final, or augride"
+ (cdr inn))))
+ rename-inners)))
+
+ ;; ---- Convert expressions ----
+ ;; Non-method definitions to set!
+ ;; Initializations args access/set!
+ (let ([exprs (map (lambda (e)
+ (syntax-case e ()
+ [(d-v (id ...) expr)
+ (and (identifier? #'d-v)
+ (free-identifier=? #'d-v #'define-values))
+ (let* ([ids (syntax->list #'(id ...))]
+ [assignment
+ (if (= 1 (length ids))
+ ;; Special-case single variable in case the RHS
+ ;; uses the name:
+ (syntax/loc e
+ (set! id ... (field-initialization-value expr)))
+ ;; General case:
+ (with-syntax ([(temp ...) (generate-temporaries ids)])
+ (syntax/loc e
+ (let-values ([(temp ...) expr])
+ (set! id (field-initialization-value temp))
+ ...
+ (void)))))])
+ (syntax-track-origin assignment e #'d-v))]
+ [(_init orig idp ...)
+ (and (identifier? (syntax _init))
+ (ormap (lambda (it)
+ (free-identifier=? it (syntax _init)))
+ (syntax-e (quote-syntax (-init
+ -init-field)))))
+ (let* ([norms (map normalize-init/field
+ (syntax->list (syntax (idp ...))))]
+ [iids (map norm-init/field-iid norms)]
+ [exids (map norm-init/field-eid norms)])
+ (with-syntax ([(id ...) iids]
+ [(idpos ...) (map localize/set-flag exids)]
+ [(defval ...)
+ (map (lambda (norm)
+ (if (stx-null? (stx-cdr norm))
+ (syntax #f)
+ (with-syntax ([defexp (stx-car (stx-cdr norm))])
+ (syntax (lambda () defexp)))))
+ norms)]
+ [class-name class-name]
+ [wrapper (if (free-identifier=? #'_init #'-init-field)
+ #'field-initialization-value
+ #'begin)])
+ (syntax-track-origin
+ (syntax/loc e
+ (begin
+ (set! id (wrapper (extract-arg 'class-name `idpos init-args defval)))
+ ...))
+ e
+ #'_init)))]
+ [(-fld orig idp ...)
+ (and (identifier? #'-fld)
+ (free-identifier=? #'-fld #'-field))
+ (with-syntax ([(((iid eid) expr) ...)
+ (map normalize-init/field (syntax->list #'(idp ...)))])
+ (syntax-track-origin
+ (syntax/loc e (begin
+ (set! iid (field-initialization-value expr))
+ ...))
+ e
+ #'-fld))]
+ [(-i-r id/rename)
+ (and (identifier? #'-i-r)
+ (free-identifier=? #'-i-r #'-init-rest))
+ (with-syntax ([n (+ (length plain-inits)
+ (length plain-init-fields)
+ -1)]
+ [id (if (identifier? #'id/rename)
+ #'id/rename
+ (stx-car #'id/rename))])
+ (syntax-track-origin
+ (syntax/loc e
+ (set! id (extract-rest-args n init-args)))
+ e
+ #'-i-r))]
+ [(-i-r)
+ (and (identifier? #'-i-r)
+ (free-identifier=? #'-i-r #'-init-rest))
+ (syntax-track-origin (syntax (void)) e #'-i-r)]
+ [_else e]))
+ exprs)]
+ [mk-method-temp
+ (lambda (id-stx)
+ (datum->syntax (quote-syntax here)
+ (gensym (syntax-e id-stx))))]
+ [rename-super-extras (append overments overrides override-finals inherit/supers)]
+ [rename-inner-extras (append pubments overments augments inherit/inners)]
+ [all-rename-inners (append (map car rename-inners)
+ (generate-temporaries (map car pubments))
+ (generate-temporaries (map car overments))
+ (generate-temporaries (map car augments))
+ (generate-temporaries (map car inherit/inners)))]
+ [all-inherits (append inherits inherit/supers inherit/inners)]
+ [definify (lambda (l)
+ (map bind-local-id l))])
+
+ ;; ---- set up field and method mappings ----
+ (with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))]
+ [(rename-super-orig-localized ...) (map lookup-localize (map car rename-supers))]
+ [(rename-super-extra-orig ...) (map car rename-super-extras)]
+ [(rename-super-temp ...) (definify (generate-temporaries (map car rename-supers)))]
+ [(rename-super-extra-temp ...) (generate-temporaries (map car rename-super-extras))]
+ [(rename-inner-orig ...) (definify (map car rename-inners))]
+ [(rename-inner-orig-localized ...) (map lookup-localize (map car rename-inners))]
+ [(rename-inner-extra-orig ...) (map car rename-inner-extras)]
+ [(rename-inner-temp ...) (generate-temporaries (map car rename-inners))]
+ [(rename-inner-extra-temp ...) (generate-temporaries (map car rename-inner-extras))]
+ [(private-name ...) (map car privates)]
+ [(private-name-localized ...) (map lookup-localize (map car privates))]
+ [(private-temp ...) (map mk-method-temp (map car privates))]
+ [(pubment-name ...) (map car pubments)]
+ [(pubment-name-localized ...) (map lookup-localize (map car pubments))]
+ [(pubment-temp ...) (map
+ mk-method-temp
+ (map car pubments))]
+ [(public-final-name ...) (map car public-finals)]
+ [(public-final-name-localized ...) (map lookup-localize (map car public-finals))]
+ [(public-final-temp ...) (map
+ mk-method-temp
+ (map car public-finals))]
+ [(method-name ...) (append local-public-dynamic-names
+ (map car all-inherits))]
+ [(method-name-localized ...) (map lookup-localize
+ (append local-public-dynamic-names
+ (map car all-inherits)))]
+ [(method-accessor ...) (generate-temporaries
+ (append local-public-dynamic-names
+ (map car all-inherits)))]
+ [(inherit-field-accessor ...) (generate-temporaries
+ (map (lambda (id)
+ (format "get-~a"
+ (syntax-e id)))
+ inherit-field-names))]
+ [(inherit-field-mutator ...) (generate-temporaries
+ (map (lambda (id)
+ (format "set-~a!"
+ (syntax-e id)))
+ inherit-field-names))]
+ [(inherit-name ...) (definify (map car all-inherits))]
+ [(inherit-field-name ...) (definify inherit-field-names)]
+ [(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)]
+ [(local-field ...) (definify
+ (append field-names
+ private-field-names))]
+ [(local-field-localized ...) (map lookup-localize
+ (append field-names
+ private-field-names))]
+ [(local-field-pos ...) (let loop ([pos 0][l (append field-names
+ private-field-names)])
+ (if (null? l)
+ null
+ (cons pos (loop (add1 pos) (cdr l)))))]
+ [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))]
+ [(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))]
+ [(plain-init-name ...) (definify plain-init-names)]
+ [(plain-init-name-localized ...) (map lookup-localize plain-init-names)]
+ [(local-plain-init-name ...) (generate-temporaries plain-init-names)])
+ (let ([mappings
+ ;; make-XXX-map is supplied by private/classidmap.rkt
+ (with-syntax ([the-obj the-obj]
+ [the-finder the-finder]
+ [this-id this-id])
+ (syntax
+ ([(inherit-field-name ...
+ local-field ...
+ rename-super-orig ...
+ rename-inner-orig ...
+ method-name ...
+ private-name ...
+ public-final-name ...
+ pubment-name ...)
+ (values
+ (make-field-map #t
+ (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax inherit-field-name)
+ (quote-syntax inherit-field-name-localized)
+ (quote-syntax inherit-field-accessor)
+ (quote-syntax inherit-field-mutator))
+ ...
+ (make-field-map #f
+ (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax local-field)
+ (quote-syntax local-field-localized)
+ (quote-syntax local-field-accessor)
+ (quote-syntax local-field-mutator))
+ ...
+ (make-rename-super-map (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax rename-super-orig)
+ (quote-syntax rename-super-orig-localized)
+ (quote-syntax rename-super-temp))
+ ...
+ (make-rename-inner-map (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax rename-inner-orig)
+ (quote-syntax rename-inner-orig-localized)
+ (quote-syntax rename-inner-temp))
+ ...
+ (make-method-map (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax method-name)
+ (quote-syntax method-name-localized)
+ (quote-syntax method-accessor))
+ ...
+ (make-direct-method-map (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax private-name)
+ (quote-syntax private-name-localized)
+ (quote private-temp))
+ ...
+ (make-direct-method-map (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax public-final-name)
+ (quote-syntax public-final-name-localized)
+ (quote public-final-temp))
+ ...
+ (make-direct-method-map (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax pubment-name)
+ (quote-syntax pubment-name-localized)
+ (quote pubment-temp))
+ ...)])))]
+ [extra-init-mappings (syntax
+ ([(plain-init-name ...)
+ (values
+ (make-init-error-map (quote-syntax plain-init-name-localized))
+ ...)]))])
+
+ (let ([find-method
+ (lambda (methods)
+ (lambda (name)
+ (ormap
+ (lambda (m)
+ (and (bound-identifier=? (car m) name)
+ (with-syntax ([proc (proc-shape (car m) (cdr m) #t
+ the-obj the-finder
+ bad class-name expand-stop-names
+ def-ctx lookup-localize)]
+ [extra-init-mappings extra-init-mappings])
+ (syntax
+ (syntax-parameterize
+ ([super-instantiate-param super-error-map]
+ [super-make-object-param super-error-map]
+ [super-new-param super-error-map])
+ (letrec-syntaxes+values extra-init-mappings ()
+ proc))))))
+ methods)))]
+ [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))])
+
+ (internal-definition-context-seal def-ctx)
+
+ ;; ---- build final result ----
+ (with-syntax ([public-names (map lookup-localize-cdr publics)]
+ [public-final-names (map lookup-localize-cdr public-finals)]
+ [override-names (map lookup-localize-cdr overrides)]
+ [override-final-names (map lookup-localize-cdr override-finals)]
+ [augride-names (map lookup-localize-cdr augrides)]
+ [pubment-names (map lookup-localize-cdr pubments)]
+ [overment-names (map lookup-localize-cdr overments)]
+ [augment-names (map lookup-localize-cdr augments)]
+ [augment-final-names (map lookup-localize-cdr augment-finals)]
+ [(rename-super-name ...) (map lookup-localize-cdr rename-supers)]
+ [(rename-super-extra-name ...) (map lookup-localize-cdr rename-super-extras)]
+ [(rename-inner-name ...) (map lookup-localize-cdr rename-inners)]
+ [(rename-inner-extra-name ...) (map lookup-localize-cdr rename-inner-extras)]
+ [inherit-names (map lookup-localize-cdr all-inherits)]
+ [abstract-names (map lookup-localize-cdr abstracts)]
+ [num-fields (datum->syntax
+ (quote-syntax here)
+ (+ (length private-field-names)
+ (length plain-init-fields)
+ (length plain-fields)))]
+ [field-names (map (lambda (norm)
+ (lookup-localize (norm-init/field-eid norm)))
+ (append
+ normal-plain-fields
+ normal-plain-init-fields))]
+ [inherit-field-names (map lookup-localize (map cdr inherit-fields))]
+ [init-names (map (lambda (norm)
+ (lookup-localize
+ (norm-init/field-eid norm)))
+ normal-inits)]
+ [init-mode init-mode]
+ [(private-method ...) (map (find-method private-methods) (map car privates))]
+ [public-methods (map (find-method methods) (map car publics))]
+ [override-methods (map (find-method methods) (map car (append overments
+ override-finals
+ overrides)))]
+ [augride-methods (map (find-method methods) (map car (append augments
+ augment-finals
+ augrides)))]
+ [(pubment-method ...) (map (find-method methods) (map car pubments))]
+ [(public-final-method ...) (map (find-method methods) (map car public-finals))]
+ ;; store a dummy method body that should never be called for abstracts
+ [(abstract-method ...) (map (lambda (abs)
+ #'(lambda (this . rest)
+ (obj-error 'class "cannot call abstract method")))
+ (map car abstracts))]
+ [mappings mappings]
+
+ [exprs exprs]
+ [the-obj the-obj]
+ [the-finder the-finder]
+ [name class-name]
+ [(stx-def ...) (map cdr stx-defines)]
+ [super-expression super-expr]
+ [(interface-expression ...) interface-exprs]
+ [inspector (if (pair? inspect-decls)
+ (stx-car (stx-cdr (car inspect-decls)))
+ #'(current-inspector))]
+ [deserialize-id-expr deserialize-id-expr]
+ [private-field-names private-field-names])
+ (class-syntax-protect
+ (add-decl-props
+ def-ctx
+ (append inspect-decls decls)
+ (quasisyntax/loc stx
+ (detect-field-unsafe-undefined
+ compose-class
+ 'name
+ super-expression
+ (list interface-expression ...)
+ inspector deserialize-id-expr #,any-localized?
+ ;; Field count:
+ num-fields
+ ;; Field names:
+ `field-names
+ `inherit-field-names
+ `private-field-names ; for undefined-checking property
+ ;; Method names:
+ `(rename-super-name ... rename-super-extra-name ...)
+ `(rename-inner-name ... rename-inner-extra-name ...)
+ `pubment-names
+ `public-final-names
+ `public-names
+ `overment-names
+ `override-final-names
+ `override-names
+ `augment-names
+ `augment-final-names
+ `augride-names
+ `inherit-names
+ `abstract-names
+ ;; Init arg names (in order)
+ `init-names
+ (quote init-mode)
+ ;; Methods (when given needed super-methods, etc.):
+ #, ;; Attach srcloc (useful for profiling)
+ (quasisyntax/loc stx
+ (lambda (local-accessor
+ local-mutator
+ inherit-field-accessor ... ; inherit
+ inherit-field-mutator ...
+ rename-super-temp ... rename-super-extra-temp ...
+ rename-inner-temp ... rename-inner-extra-temp ...
+ method-accessor ...) ; for a local call that needs a dynamic lookup
+ (define-syntax-parameter the-finder #f)
+ (let ([local-field-accessor
+ (make-struct-field-accessor local-accessor local-field-pos #f)]
+ ...
+ [local-field-mutator
+ (make-struct-field-mutator local-mutator local-field-pos #f)]
+ ...)
+ (syntax-parameterize
+ ([this-param (make-this-map (quote-syntax this-id)
+ (quote-syntax the-finder)
+ (quote the-obj))]
+ [this%-param (make-this%-map (quote-syntax (object-ref this))
+ (quote-syntax the-finder))])
+ (let-syntaxes
+ mappings
+ (syntax-parameterize
+ ([super-param
+ (lambda (stx)
+ (syntax-case stx (rename-super-extra-orig ...)
+ [(_ rename-super-extra-orig . args)
+ (generate-super-call
+ stx
+ (quote-syntax the-finder)
+ (quote the-obj)
+ (quote-syntax rename-super-extra-temp)
+ (syntax args))]
+ ...
+ [(_ id . args)
+ (identifier? #'id)
+ (raise-syntax-error
+ #f
+ (string-append
+ "identifier for super call does not have an override, "
+ "override-final, overment, or inherit/super declaration")
+ stx
+ #'id)]
+ [_else
+ (raise-syntax-error
+ #f
+ "expected an identifier after the keyword"
+ stx)]))]
+ [inner-param
+ (lambda (stx)
+ (syntax-case stx (rename-inner-extra-orig ...)
+ [(_ default-expr rename-inner-extra-orig . args)
+ (generate-inner-call
+ stx
+ (quote-syntax the-finder)
+ (quote the-obj)
+ (syntax default-expr)
+ (quote-syntax rename-inner-extra-temp)
+ (syntax args))]
+ ...
+ [(_ default-expr id . args)
+ (identifier? #'id)
+ (raise-syntax-error
+ #f
+ (string-append
+ "identifier for inner call does not have a pubment, augment, "
+ "overment, or inherit/inner declaration")
+ stx
+ #'id)]
+ [(_)
+ (raise-syntax-error
+ #f
+ "expected a default-value expression after the keyword"
+ stx
+ #'id)]
+ [_else
+ (raise-syntax-error
+ #f
+ "expected an identifier after the keyword and default-value expression"
+ stx)]))])
+ stx-def ...
+ (letrec ([private-temp private-method]
+ ...
+ [pubment-temp pubment-method]
+ ...
+ [public-final-temp public-final-method]
+ ...)
+ (values
+ (list pubment-temp ... public-final-temp ...
+ abstract-method ... . public-methods)
+ (list . override-methods)
+ (list . augride-methods)
+ ;; Initialization
+ #, ;; Attach srcloc (useful for profiling)
+ (quasisyntax/loc stx
+ (lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
+ (syntax-parameterize ([the-finder (quote-syntax the-obj)])
+ (syntax-parameterize
+ ([super-instantiate-param
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ (arg (... ...)) (kw kwarg) (... ...))
+ (with-syntax ([stx stx])
+ (syntax
+ (begin
+ `(declare-super-new)
+ (-instantiate super-go stx #f (the-obj si_c si_inited?
+ si_leftovers)
+ (list arg (... ...))
+ (kw kwarg) (... ...)))))]))]
+ [super-new-param
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ (kw kwarg) (... ...))
+ (with-syntax ([stx stx])
+ (syntax
+ (begin
+ `(declare-super-new)
+ (-instantiate super-go stx #f (the-obj si_c si_inited?
+ si_leftovers)
+ null
+ (kw kwarg) (... ...)))))]))]
+ [super-make-object-param
+ (lambda (stx)
+ (let ([code
+ (quote-syntax
+ (lambda args
+ (super-go the-obj si_c si_inited? si_leftovers args null)))])
+ #`(begin
+ `(declare-super-new)
+ #,(if (identifier? stx)
+ code
+ (datum->syntax
+ code
+ (cons code
+ (cdr (syntax-e stx))))))))])
+ (letrec-syntaxes+values
+ ([(plain-init-name) (make-init-redirect
+ (quote-syntax local-plain-init-name)
+ (quote-syntax plain-init-name-localized))] ...)
+ ([(local-plain-init-name) unsafe-undefined] ...)
+ (void) ; in case the body is empty
+ (begin
+ '(declare-field-use-start) ; see "class-undef.rkt"
+ . exprs))))))))))))))
+ ;; Extra argument added here by `detect-field-unsafe-undefined`
+ #; check-undef?
+ ;; Not primitive:
+ #f)))))))))))))))))
+
+ ;; The class* and class entry points:
+ (values
+ ;; class*
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ super-expression (interface-expr ...)
+ defn-or-expr
+ ...)
+ (main stx
+ #'super-expression
+ #f #f
+ (syntax->list #'(interface-expr ...))
+ (syntax->list #'(defn-or-expr ...)))]
+ [(_ super-expression no-parens-interface-expr
+ defn-or-expr
+ ...)
+ (raise-syntax-error 'class*
+ "expected a sequence of interfaces"
+ stx
+ #'no-parens-interface-expr)]))
+ ;; class
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ super-expression
+ defn-or-expr
+ ...)
+ (main stx
+ #'super-expression
+ #f #f
+ null
+ (syntax->list #'(defn-or-expr ...)))]))
+ ;; class/derived
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ orig-stx
+ [name-id super-expression (interface-expr ...) deserialize-id-expr]
+ defn-or-expr
+ ...)
+ (main #'orig-stx
+ #'super-expression
+ #'deserialize-id-expr
+ (and (syntax-e #'name-id) #'name-id)
+ (syntax->list #'(interface-expr ...))
+ (syntax->list #'(defn-or-expr ...)))]))
+ )))
+
+(define-syntax (-define-serializable-class stx)
+ (syntax-case stx ()
+ [(_ orig-stx name super-expression (interface-expr ...)
+ defn-or-expr ...)
+ (let ([deserialize-name-info (datum->syntax
+ #'name
+ (string->symbol
+ (format "deserialize-info:~a" (syntax-e #'name)))
+ #'name)])
+ (unless (memq (syntax-local-context) '(top-level module))
+ (raise-syntax-error
+ #f
+ "allowed only at the top level or within a module top level"
+ #'orig-stx))
+ (with-syntax ([deserialize-name-info deserialize-name-info]
+ [(provision ...) (if (eq? (syntax-local-context) 'module)
+ #`((runtime-require (submod "." deserialize-info))
+ (module+ deserialize-info (provide #,deserialize-name-info)))
+ #'())])
+ (class-syntax-protect
+ #'(begin
+ (define-values (name deserialize-name-info)
+ (class/derived orig-stx [name
+ super-expression
+ (interface-expr ...)
+ #'deserialize-name-info]
+ defn-or-expr ...))
+ provision ...))))]))
+
+(define-syntax (define-serializable-class* stx)
+ (syntax-case stx ()
+ [(_ name super-expression (interface-expr ...)
+ defn-or-expr ...)
+ (with-syntax ([orig-stx stx])
+ (class-syntax-protect
+ #'(-define-serializable-class orig-stx
+ name
+ super-expression
+ (interface-expr ...)
+ defn-or-expr ...)))]))
+
+(define-syntax (define-serializable-class stx)
+ (syntax-case stx ()
+ [(_ name super-expression
+ defn-or-expr ...)
+ (with-syntax ([orig-stx stx])
+ (class-syntax-protect
+ #'(-define-serializable-class orig-stx
+ name
+ super-expression
+ ()
+ defn-or-expr ...)))]))
+
+(define-syntaxes (private* public* pubment* override* overment* augride* augment*
+ public-final* override-final* augment-final*)
+ (let ([mk
+ (lambda (who decl-form)
+ (lambda (stx)
+ (unless (class-top-level-context? (syntax-local-context))
+ (raise-syntax-error
+ #f
+ "use of a class keyword is not in a class top-level"
+ stx))
+ (syntax-case stx ()
+ [(_ binding ...)
+ (let ([bindings (syntax->list (syntax (binding ...)))])
+ (let ([name-exprs
+ (map (lambda (binding)
+ (syntax-case binding ()
+ [(name expr)
+ (identifier? (syntax name))
+ (cons (syntax name) (syntax expr))]
+ [_else
+ (identifier? (syntax name))
+ (raise-syntax-error
+ #f
+ "expected an identifier and expression"
+ stx
+ binding)]))
+ bindings)])
+ (with-syntax ([(name ...) (map car name-exprs)]
+ [(expr ...) (map cdr name-exprs)]
+ [decl-form decl-form])
+ (class-syntax-protect
+ (syntax
+ (begin
+ (decl-form name ...)
+ (define name expr)
+ ...))))))])))])
+ (values
+ (mk 'private* (syntax private))
+ (mk 'public* (syntax public))
+ (mk 'pubment* (syntax pubment))
+ (mk 'override* (syntax override))
+ (mk 'overment* (syntax overment))
+ (mk 'augride* (syntax augride))
+ (mk 'augment* (syntax augment))
+ (mk 'public-final* (syntax public-final))
+ (mk 'override-final* (syntax override-final))
+ (mk 'augment-final* (syntax augment)))))
+
+(define-syntaxes (define/private define/public define/pubment
+ define/override define/overment
+ define/augride define/augment
+ define/public-final define/override-final define/augment-final)
+ (let ([mk
+ (lambda (decl-form)
+ (lambda (stx)
+ (unless (class-top-level-context? (syntax-local-context))
+ (raise-syntax-error
+ #f
+ "use of a class keyword is not in a class top-level"
+ stx))
+ (let-values ([(id rhs) (normalize-definition stx #'lambda #f #t)])
+ (quasisyntax/loc stx
+ (begin
+ (#,decl-form #,id)
+ (define #,id #,rhs))))))])
+ (values
+ (mk #'private)
+ (mk #'public)
+ (mk #'pubment)
+ (mk #'override)
+ (mk #'overment)
+ (mk #'augride)
+ (mk #'augment)
+ (mk #'public-final)
+ (mk #'override-final)
+ (mk #'augment-final))))
+
+(define-syntax (define-local-member-name stx)
+ (syntax-case stx ()
+ [(_ id ...)
+ (let ([ids (syntax->list (syntax (id ...)))])
+ (for-each (lambda (id)
+ (unless (identifier? id)
+ (raise-syntax-error
+ #f
+ "expected an identifier"
+ stx
+ id)))
+ ids)
+ (let ([dup (check-duplicate-identifier ids)])
+ (when dup
+ (raise-syntax-error
+ #f
+ "duplicate identifier"
+ stx
+ dup)))
+ (if (eq? (syntax-local-context) 'top-level)
+ ;; Does nothing in particular at the top level:
+ (syntax/loc stx (define-syntaxes (id ...) (values 'id ...)))
+ ;; Map names to private indicators, which are made private
+ ;; simply by introduction:
+ (with-syntax ([(gen-id ...) (generate-temporaries ids)])
+ (with-syntax ([stx-defs
+ ;; Need to attach srcloc to this definition:
+ (syntax/loc stx
+ (define-syntaxes (id ...)
+ (values (make-private-name (quote-syntax id) (quote-syntax gen-id))
+ ...)))])
+ (class-syntax-protect
+ (syntax/loc stx
+ (begin
+ (define-values (gen-id ...)
+ (values (generate-local-member-name 'id) ...))
+ stx-defs)))))))]))
+
+(define-syntax (define-member-name stx)
+ (syntax-case stx ()
+ [(_ id expr)
+ (let ([name #'id])
+ (unless (identifier? name)
+ (raise-syntax-error
+ #f
+ "expected an identifier for definition"
+ stx
+ name))
+ (with-syntax ([stx-def
+ ;; Need to attach srcloc to this definition:
+ (syntax/loc stx
+ (define-syntax id
+ (make-private-name (quote-syntax id)
+ ((syntax-local-certifier) (quote-syntax member-name)))))])
+ (class-syntax-protect
+ #'(begin
+ (define member-name (check-member-key 'id expr))
+ stx-def))))]))
+
+(define (generate-local-member-name id)
+ (string->uninterned-symbol
+ (symbol->string id)))
+
+
+(define-values (struct:member-key make-member-key member-name-key? member-key-ref member-key-set!)
+ (make-struct-type 'member-name-key
+ #f
+ 1 0 #f
+ (list
+ (cons prop:custom-write
+ (lambda (v p write?)
+ (fprintf p "#<member-key:~a>" (member-key-id v)))))))
+
+(define member-key-id (make-struct-field-accessor member-key-ref 0))
+
+(define (check-member-key id v)
+ (unless (member-name-key? v)
+ (obj-error 'define-local-member-name
+ "value is not a member key"
+ "value" v
+ "local name" (as-write id)))
+ (member-key-id v))
+
+(define-syntax (member-name-key stx)
+ (syntax-case stx ()
+ [(_ id)
+ (identifier? #'id)
+ (with-syntax ([id (localize #'id)])
+ (class-syntax-protect
+ (syntax/loc stx (make-member-key `id))))]
+ [(_ x)
+ (raise-syntax-error
+ #f
+ "not an identifier"
+ stx
+ #'x)]))
+
+(define (generate-member-key)
+ (make-member-key (generate-local-member-name (gensym 'member))))
+
+(define (member-name-key=? a b)
+ (if (and (member-name-key? a)
+ (member-name-key? b))
+ (eq? (member-key-id a) (member-key-id b))
+ (eq? a b)))
+
+(define (member-name-key-hash-code a)
+ (unless (member-name-key? a)
+ (raise-argument-error
+ 'member-name-key-hash-code
+ "member-name-key?"
+ a))
+ (eq-hash-code (member-key-id a)))
+
+;;--------------------------------------------------------------------
+;; class implementation
+;;--------------------------------------------------------------------
+
+(define-struct class (name
+ pos supers ; pos is subclass depth, supers is vector
+ self-interface ; self interface
+ insp-mk ; dummy struct maker to control inspection access
+ obj-inspector ; the inspector used for instances of this class
+
+ method-width ; total number of methods
+ method-ht ; maps public names to vector positions
+ method-ids ; reverse-ordered list of public method names
+ abstract-ids ; list of abstract method names
+ method-ictcs ; list of indices of methods to fix for interface ctcs
+
+ [ictc-classes ; #f or weak hash of cached classes keyed by blame
+ #:mutable]
+
+ methods ; vector of methods (for external dynamic dispatch)
+ ; vector might also contain lists; see comment below from Stevie
+ super-methods ; vector of methods (for subclass super calls)
+ int-methods ; vector of vector of methods (for internal dynamic dispatch)
+ beta-methods ; vector of vector of methods
+ meth-flags ; vector: #f => primitive-implemented
+ ; 'final => final
+ ; 'augmentable => can augment
+
+ inner-projs ; vector of projections for the last inner slot
+ dynamic-idxs ; vector of indexs for access into int-methods
+ dynamic-projs ; vector of vector of projections for internal dynamic dispatch
+
+ field-width ; total number of fields
+ field-pub-width ; total number of public fields
+ field-ht ; maps public field names to field-infos (see make-field-info above)
+ field-ids ; list of public field names
+ all-field-ids ; list of field names in reverse order, used for `undefined` error reporting
+
+ [struct:object ; structure type for instances
+ #:mutable]
+ [object? ; predicate
+ #:mutable]
+ [make-object ; : (-> object), constructor that creates an uninitialized object
+ #:mutable]
+ [field-ref ; accessor
+ #:mutable]
+ [field-set! ; mutator
+ #:mutable]
+
+ init-args ; list of symbols in order; #f => only by position
+ init-mode ; 'normal, 'stop (don't accept by-pos for super), or 'list
+
+ [init ; initializer
+ #:mutable] ; : object
+ ; (object class (box boolean) leftover-args new-by-pos-args new-named-args
+ ; -> void) // always continue-make-super?
+ ; class
+ ; (box boolean)
+ ; leftover-args
+ ; named-args
+ ; -> void
+
+ [orig-cls ; uncontracted version of this class (or same class)
+ #:mutable]
+ [serializer ; proc => serializer, #f => not serializable
+ #:mutable]
+ [fixup ; for deserialization
+ #:mutable]
+
+ check-undef? ; objects need an unsafe-undefined guarding chaperone?
+
+ no-super-init?); #t => no super-init needed
+ #:inspector insp
+ #:property prop:equal+hash
+ (list (λ (cls-a cls-b recur) (eq? (class-orig-cls cls-a) (class-orig-cls cls-b)))
+ (λ (cls recur) (eq-hash-code (class-orig-cls cls)))
+ (λ (cls recur) (eq-hash-code (class-orig-cls cls)))))
+
+#|
+
+From Stevie, explaining the shape of the elements of the vector in the 'methods' field:
+
+For each level of interface, we build up the following structure:
+
+(list <contract> <name of interface that contains this contract> <pos blame or #f> <neg blame or #f>)
+
+The second part of the list is used for certain types of failure reporting, I think,
+whereas the other parts are what we need to build the correct contract forms (once we
+have the method implementation to contract). In the interface contract info returned
+from a list of contracts, the info for the leaves contains #f negative blame (which
+will be filled in with the class that implements the interface) and the info for the
+"roots" (more on that later) contains #f positive blame (which is filled in with the
+info for the client of the class).
+
+When we have a particular class, we can fill in the neg. blame for the leaves in the hierarchy, and
+then we also apply as much of these structures have complete data to the method implementation
+(that is, non-#f pos and neg blames so we can appropriately construct the correct `contract' forms).
+
+What's left is a list of non-complete data for the root(s) of the hierarchy (by roots, I mean
+the first interfaces where this method is mentioned in the interface hierarchy). We store that
+list along with the method implementation, so that once we have the neg. blame (the blame region
+that instantiates the class in question), we can complete this data and apply those
+last few projections.
+
+|#
+
+;; compose-class: produces one result if `deserialize-id' is #f, two
+;; results if `deserialize-id' is not #f
+(define (compose-class name ; symbol
+ super ; class, possibly with contract impersonator properties
+ interfaces ; list of interfaces
+ inspector ; inspector or #f
+ deserialize-id ; identifier or #f
+ any-localized? ; #t => need to double-check distinct external names
+
+ num-fields ; total fields (public & private)
+ public-field-names ; list of symbols (shorter than num-fields)
+ inherit-field-names ; list of symbols (not included in num-fields)
+ private-field-names ; list of symbols (the rest of num-fields)
+
+ rename-super-names ; list of symbols
+ rename-inner-names
+ pubment-names
+ public-final-names
+ public-normal-names
+ overment-names
+ override-final-names
+ override-normal-names
+ augment-names
+ augment-final-names
+ augride-normal-names
+ inherit-names
+ abstract-names
+
+ init-args ; list of symbols in order, or #f
+ init-mode ; 'normal, 'stop, or 'list
+
+ make-methods ; takes field and method accessors
+
+ check-undef?
+
+ make-struct:prim) ; see "primitive classes", below
+ (define (make-method proc meth-name)
+ (procedure-rename
+ (procedure->method proc)
+ (string->symbol
+ (format "~a method~a~a"
+ meth-name
+ (if name " in " "")
+ (or name "")))))
+
+ ;; -- Check superclass --
+ (unless (class? super)
+ (obj-error 'class* "superclass expression result is not a class"
+ "result" super
+ #:class-name name))
+
+ (when any-localized?
+ (check-still-unique name
+ init-args
+ "initialization argument names")
+ ;; We intentionally leave inherited names out of the lists below,
+ ;; on the theory that it's ok to decide to inherit from yourself:
+ (check-still-unique name public-field-names "field names")
+ (check-still-unique name
+ (append pubment-names public-final-names public-normal-names
+ overment-names override-final-names override-normal-names
+ augment-names augment-final-names augride-normal-names
+ abstract-names)
+ "method names"))
+
+ ;; -- Run class-seal/unseal checkers --
+ (when (has-seals? super)
+ (define seals (get-seals super))
+ (define all-inits init-args)
+ (define all-fields (append public-field-names inherit-field-names))
+ (define all-methods (append rename-super-names
+ rename-inner-names
+ pubment-names
+ public-final-names
+ public-normal-names
+ overment-names
+ override-final-names
+ override-normal-names
+ augment-names
+ augment-final-names
+ augride-normal-names
+ inherit-names
+ abstract-names))
+ (define all-init-checkers
+ (map (λ (sl) (seal-init-checker sl)) seals))
+ (define all-field-checkers
+ (map (λ (sl) (seal-field-checker sl)) seals))
+ (define all-method-checkers
+ (map (λ (sl) (seal-method-checker sl)) seals))
+ (for ([f all-init-checkers]) (f all-inits))
+ (for ([f all-field-checkers]) (f all-fields))
+ (for ([f all-method-checkers]) (f all-methods)))
+
+ ;; -- Create new class's name --
+ (let* ([name (or name
+ (let ([s (class-name super)])
+ (and s
+ (not (eq? super object%))
+ (if (symbol? s) ;; how can 's' not be a symbol at this point?
+ (string->symbol (format "derived-from-~a" s))
+ s))))]
+ ;; Combine method lists
+ [public-names (append pubment-names public-final-names public-normal-names abstract-names)]
+ [override-names (append overment-names override-final-names override-normal-names)]
+ [augride-names (append augment-names augment-final-names augride-normal-names)]
+ [final-names (append public-final-names override-final-names augment-final-names)]
+ [augonly-names (append pubment-names overment-names augment-names)]
+ ;; Misc utilities
+ [no-new-methods? (null? public-names)]
+ [no-method-changes? (and (null? public-names)
+ (null? override-names)
+ (null? augride-names)
+ (null? final-names))]
+ [no-new-fields? (null? public-field-names)]
+ [xappend (lambda (a b) (if (null? b) a (append a b)))])
+
+ ;; -- Check interfaces ---
+ (for-each
+ (lambda (intf)
+ (unless (interface? intf)
+ (obj-error 'class* "interface expression result is not an interface"
+ "result" intf
+ #:class-name name)))
+ interfaces)
+
+ ;; -- Check inspectors ---
+ (when inspector
+ (unless (inspector? inspector)
+ (obj-error 'class* "class `inspect' result is not an inspector or #f"
+ "result" inspector
+ #:class-name name)))
+
+ ;; -- Match method and field names to indices --
+ (let ([method-ht (if no-new-methods?
+ (class-method-ht super)
+ (hash-copy (class-method-ht super)))]
+ [field-ht (if no-new-fields?
+ (class-field-ht super)
+ (hash-copy (class-field-ht super)))]
+ [super-method-ht (class-method-ht super)]
+ [super-method-ids (class-method-ids super)]
+ [super-field-ids (class-field-ids super)]
+ [super-field-ht (class-field-ht super)]
+ [super-abstract-ids (class-abstract-ids super)])
+
+ ;; Put new ids in table, with pos (replace field pos with accessor info later)
+ (unless no-new-methods?
+ (for ([id (in-list public-names)]
+ [p (in-naturals (class-method-width super))])
+ (when (hash-ref method-ht id #f)
+ (obj-error 'class* "superclass already contains method"
+ "superclass" super
+ "method name" (as-write id)
+ #:class-name name))
+ (hash-set! method-ht id p)))
+
+ ;; Keep check here for early failure, will add to hashtable later in this function.
+ (unless no-new-fields?
+ (for ([id (in-list public-field-names)])
+ (when (hash-ref field-ht id #f)
+ (obj-error 'class* "superclass already contains field"
+ "superclass" super
+ "field name" (as-write id)
+ #:class-name name))))
+
+ ;; Check that superclass has expected fields
+ (for-each (lambda (id)
+ (unless (hash-ref field-ht id #f)
+ (obj-error 'class* "superclass does not provide field"
+ "superclass" super
+ "field name" (as-write id)
+ (and name "class") name)))
+ inherit-field-names)
+
+ ;; Check that superclass has expected methods, and get indices
+ (let ([get-indices
+ (lambda (method-ht what ids)
+ (map
+ (lambda (id)
+ (hash-ref
+ method-ht id
+ (lambda ()
+ (obj-error 'class*
+ (format "~a does not provide an expected method for ~a"
+ (if (eq? method-ht super-method-ht) "superclass" "class")
+ what)
+ (format "~a name" what) (as-write id)
+ #:class-name name))))
+ ids))]
+ [method-width (+ (class-method-width super) (length public-names))]
+ [field-width (+ (class-field-width super) num-fields)]
+ [field-pub-width (+ (class-field-pub-width super) (length public-field-names))])
+ (let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)]
+ [replace-augonly-indices (get-indices super-method-ht "overment" overment-names)]
+ [replace-final-indices (get-indices super-method-ht "override-final" override-final-names)]
+ [replace-normal-indices (get-indices super-method-ht "override" override-normal-names)]
+ [refine-augonly-indices (get-indices super-method-ht "augment" augment-names)]
+ [refine-final-indices (get-indices super-method-ht "augment-final" augment-final-names)]
+ [refine-normal-indices (get-indices super-method-ht "augride" augride-normal-names)]
+ [rename-super-indices (get-indices super-method-ht "rename-super" rename-super-names)]
+ [rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)]
+ [new-augonly-indices (get-indices method-ht "pubment" pubment-names)]
+ [new-final-indices (get-indices method-ht "public-final" public-final-names)]
+ [new-normal-indices (get-indices method-ht "public" public-normal-names)]
+ [new-abstract-indices (get-indices method-ht "abstract" abstract-names)])
+
+ ;; -- Check that all interfaces are satisfied --
+ (for-each
+ (lambda (intf)
+ (for-each
+ (lambda (var)
+ (unless (hash-ref method-ht var #f)
+ (obj-error 'class*
+ "missing interface-required method"
+ "method name" (as-write var)
+ (and name "class name") (as-write name)
+ (and (interface-name intf) "interface name") (as-write (interface-name intf)))))
+ (interface-public-ids intf)))
+ interfaces)
+ (let ([c (get-implement-requirement interfaces 'class* #:class-name name)])
+ (when (and c (not (subclass? super c)))
+ (obj-error 'class*
+ "interface-required implementation not satisfied"
+ (and name "class name") (as-write name)
+ (and (class-name c) "required class name") (as-write (class-name c)))))
+
+ ;; -- For serialization, check that the superclass is compatible --
+ (when deserialize-id
+ (unless (class-serializer super)
+ (obj-error 'class*
+ "superclass is not serialiazable, not transparent, and does not implement externalizable<%>"
+ "superclass" super
+ #:class-name name)))
+
+ ;; ---- Make the class and its interface ----
+ (let* ([class-make (if name
+ (make-naming-constructor struct:class name "class")
+ make-class)]
+ [interface-make (if name
+ (make-naming-constructor
+ struct:interface
+ (string->symbol (format "interface:~a" name))
+ #f)
+ make-interface)]
+ [method-names (append (reverse public-names) super-method-ids)]
+ [field-names (append public-field-names super-field-ids)]
+ ;; Superclass abstracts that have not been concretized
+ [remaining-abstract-names
+ (append abstract-names
+ (remq* override-names super-abstract-ids))]
+ [super-interfaces (cons (class-self-interface super) interfaces)]
+ [i (interface-make name super-interfaces #f method-names (make-immutable-hash) #f null)]
+ [methods (if no-method-changes?
+ (class-methods super)
+ (make-vector method-width))]
+ [super-methods (if no-method-changes?
+ (class-super-methods super)
+ (make-vector method-width))]
+ [int-methods (if no-method-changes?
+ (class-int-methods super)
+ (make-vector method-width))]
+ [beta-methods (if no-method-changes?
+ (class-beta-methods super)
+ (make-vector method-width))]
+ [inner-projs (if no-method-changes?
+ (class-inner-projs super)
+ (make-vector method-width))]
+ [dynamic-idxs (if no-method-changes?
+ (class-dynamic-idxs super)
+ (make-vector method-width))]
+ [dynamic-projs (if no-method-changes?
+ (class-dynamic-projs super)
+ (make-vector method-width))]
+ [meth-flags (if no-method-changes?
+ (class-meth-flags super)
+ (make-vector method-width))]
+ [c (class-make name
+ (add1 (class-pos super))
+ (list->vector (append (vector->list (class-supers super)) (list #f)))
+ i
+ (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
+ make-)
+ inspector
+ method-width method-ht method-names remaining-abstract-names
+ (interfaces->contracted-methods (list i))
+ #f
+ methods super-methods int-methods beta-methods meth-flags
+ inner-projs dynamic-idxs dynamic-projs
+ field-width field-pub-width field-ht field-names
+ (append (reverse private-field-names)
+ (reverse public-field-names)
+ (class-all-field-ids super))
+ 'struct:object 'object? 'make-object 'field-ref 'field-set!
+ init-args
+ init-mode
+ 'init
+ #f #f #f ; serializer is set later
+ (or check-undef? (class-check-undef? super))
+ (and make-struct:prim #t))]
+ [obj-name (if name
+ (string->symbol (format "object:~a" name))
+ 'object)]
+ ;; Used only for prim classes
+ [preparer (lambda (name)
+ ;; Map symbol to number:
+ (hash-ref method-ht name))]
+ [dispatcher (lambda (obj n)
+ ;; Extract method:
+ (vector-ref (class-methods (object-ref obj)) n))])
+
+ (setup-all-implemented! i)
+ (vector-set! (class-supers c) (add1 (class-pos super)) c)
+ (set-class-orig-cls! c c)
+
+
+ ;; --- Make the new external method contract records ---
+ ;; (they are just copies of the super at this point, updated below)
+ (define wci-neg-extra-arg-vec
+ (if (impersonator-prop:has-wrapped-class-neg-party? super)
+ (let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
+ [ov (wrapped-class-info-neg-extra-arg-vec the-info)])
+ (if no-method-changes?
+ ov
+ (let ([v (make-vector method-width #f)])
+ (vector-copy! v 0 ov)
+ v)))
+ #f))
+ (define wci-neg-acceptors-ht
+ (if (impersonator-prop:has-wrapped-class-neg-party? super)
+ (let* ([the-info (impersonator-prop:get-wrapped-class-info super)]
+ [oh (wrapped-class-info-neg-acceptors-ht the-info)])
+ (if no-method-changes?
+ oh
+ (hash-copy oh)))
+ #f))
+
+ ;; --- Make the new object struct ---
+ (let*-values ([(prim-object-make prim-object? struct:prim-object)
+ (if make-struct:prim
+ (make-struct:prim c prop:object
+ preparer dispatcher
+ (get-properties interfaces))
+ (values #f #f #f))]
+ [(struct:object object-make object? object-field-ref object-field-set!)
+ (if make-struct:prim
+ ;; Use prim struct:
+ (values struct:prim-object prim-object-make prim-object? #f #f)
+ ;; Normal struct creation:
+ (make-struct-type obj-name
+ (add-properties (class-struct:object super) interfaces)
+ 0 ;; No init fields
+ ;; Fields for new slots:
+ num-fields unsafe-undefined
+ ;; Map object property to class:
+ (append
+ (list (cons prop:object c))
+ (if (class-check-undef? c)
+ (list (cons prop:chaperone-unsafe-undefined
+ (class-all-field-ids c)))
+ null)
+ (if deserialize-id
+ (list
+ (cons prop:serializable
+ ;; Serialization:
+ (make-serialize-info
+ (lambda (obj)
+ ((class-serializer c) obj))
+ deserialize-id
+ (not (interface-extension? i externalizable<%>))
+ (or (current-load-relative-directory)
+ (current-directory)))))
+ null))
+ inspector))])
+ (set-class-struct:object! c struct:object)
+ (set-class-object?! c object?)
+ (set-class-make-object! c object-make)
+ (unless (zero? num-fields)
+ ;; We need these only if there are fields, used for for public-field
+ ;; access or for inspection:
+ (set-class-field-ref! c object-field-ref)
+ (set-class-field-set!! c object-field-set!))
+
+ ;; --- Build field accessors and mutators ---
+ ;; Use public field names to name the accessors and mutators
+ (let-values ([(inh-accessors inh-mutators)
+ (for/lists (accs muts) ([id (in-list inherit-field-names)])
+ (let ([fi (hash-ref field-ht id)])
+ (values (field-info-internal-ref fi) (field-info-internal-set! fi))))])
+ ;; Add class/index pairs for public fields.
+ (unless no-new-fields?
+ (for ([id (in-list public-field-names)]
+ [i (in-naturals)])
+ (hash-set! field-ht id (make-field-info c i))))
+
+ ;; -- Extract superclass methods and make rename-inners ---
+ (let ([rename-supers (map (lambda (index mname)
+ ;; While the last part of the vector is indeed the right
+ ;; method, if there have been super contracts placed since,
+ ;; they won't be reflected there, only in the super-methods
+ ;; vector of the superclass.
+ (let ([vec (vector-ref (class-beta-methods super) index)])
+ (when (and (positive? (vector-length vec))
+ (not (vector-ref vec (sub1 (vector-length vec)))))
+ (obj-error 'class*
+ (string-append
+ "superclass method for override, overment, inherit/super, "
+ "or rename-super is not overrideable")
+ "superclass" super
+ "method name" (as-write mname)
+ #:class-name name)))
+ (vector-ref (class-super-methods super) index))
+ rename-super-indices
+ rename-super-names)]
+ [rename-inners (let ([new-augonly (make-vector method-width #f)])
+ (define (get-depth index)
+ (+ (if (index . < . (class-method-width super))
+ (vector-length (vector-ref (class-beta-methods super)
+ index))
+ 0)
+ (if (vector-ref new-augonly index) 0 -1)))
+ ;; To compute `rename-inner' indices, we need to know which methods
+ ;; are augonly in this new class.
+ (for-each (lambda (id)
+ (vector-set! new-augonly (hash-ref method-ht id) #t))
+ (append pubment-names overment-names))
+ (let ([check-aug
+ (lambda (maybe-here?)
+ (lambda (mname index)
+ (let ([aug-ok?
+ (or (if (index . < . (class-method-width super))
+ (eq? (vector-ref (class-meth-flags super) index) 'augmentable)
+ #f)
+ (and maybe-here?
+ (or (memq mname pubment-names)
+ (memq mname overment-names))))])
+ (unless aug-ok?
+ (obj-error 'class*
+ (string-append
+ "superclass method for augride, augment, inherit/inner, "
+ "or rename-inner method is not augmentable")
+ "superclass" super
+ "method name" (as-write mname)
+ #:class-name name)))))])
+ (for-each (check-aug #f)
+ augride-normal-names
+ (get-indices method-ht "augride" augride-normal-names))
+ (for-each (check-aug #f)
+ augment-final-names
+ refine-final-indices)
+ (for-each (check-aug #t)
+ rename-inner-names
+ rename-inner-indices))
+ ;; Now that checking is done, add `augment':
+ (for-each (lambda (id)
+ (vector-set! new-augonly (hash-ref method-ht id) #t))
+ augment-names)
+ (map (lambda (mname index)
+ (let ([depth (get-depth index)])
+ (lambda (obj)
+ (vector-ref (vector-ref (class-beta-methods (object-ref obj))
+ index)
+ depth))))
+ rename-inner-names
+ rename-inner-indices))])
+
+ ;; Have to update these before making the method-accessors, since this is a "static" piece
+ ;; of information (instead of being dynamic => method call time).
+ (unless no-method-changes?
+ (vector-copy! dynamic-idxs 0 (class-dynamic-idxs super))
+ (for-each (lambda (index)
+ (vector-set! dynamic-idxs index 0))
+ (append new-augonly-indices new-final-indices
+ new-normal-indices new-abstract-indices)))
+
+ ;; -- Create method accessors --
+ (let ([method-accessors
+ (map (lambda (index)
+ (let ([dyn-idx (vector-ref dynamic-idxs index)])
+ (lambda (obj)
+ (vector-ref (vector-ref (class-int-methods (object-ref obj))
+ index)
+ dyn-idx))))
+ (append new-normal-indices replace-normal-indices refine-normal-indices
+ replace-augonly-indices refine-augonly-indices
+ replace-final-indices refine-final-indices
+ new-abstract-indices inherit-indices))])
+
+ ;; -- Get new methods and initializers --
+ (let-values ([(new-methods override-methods augride-methods init)
+ (apply make-methods object-field-ref object-field-set!
+ (append inh-accessors
+ inh-mutators
+ rename-supers
+ rename-inners
+ method-accessors))])
+ ;; -- Fill in method tables --
+ ;; First copy old methods
+ (unless no-method-changes?
+ (vector-copy! methods 0 (class-methods super))
+ (vector-copy! super-methods 0 (class-super-methods super))
+ (vector-copy! int-methods 0 (class-int-methods super))
+ (vector-copy! beta-methods 0 (class-beta-methods super))
+ (vector-copy! meth-flags 0 (class-meth-flags super))
+ (vector-copy! inner-projs 0 (class-inner-projs super))
+ (vector-copy! dynamic-projs 0 (class-dynamic-projs super)))
+ ;; Add new methods:
+ (for-each (lambda (index method)
+ (vector-set! methods index method)
+ (vector-set! super-methods index method)
+ (vector-set! int-methods index (vector method))
+ (vector-set! beta-methods index (vector))
+ (vector-set! inner-projs index values)
+ (vector-set! dynamic-idxs index 0)
+ (vector-set! dynamic-projs index (vector values)))
+ (append new-augonly-indices new-final-indices
+ new-abstract-indices new-normal-indices)
+ new-methods)
+ ;; Add only abstracts, making sure the super method just calls (void)
+ (let ([dummy (lambda args (void))])
+ (for-each (lambda (index)
+ (vector-set! super-methods index dummy))
+ new-abstract-indices))
+ ;; Override old methods:
+ (for-each (lambda (index method id)
+ (when (eq? 'final (vector-ref meth-flags index))
+ (obj-error 'class*
+ "cannot override or augment final method"
+ "method name" (as-write id)
+ #:class-name name))
+ (let ([v (vector-ref beta-methods index)])
+ (if (zero? (vector-length v))
+ ;; Normal mode - set vtable entry
+ (begin (vector-set! methods index method)
+ (vector-set! super-methods index method)
+ (let* ([dyn-idx (vector-ref dynamic-idxs index)]
+ [new-vec (make-vector (add1 dyn-idx))]
+ [proj-vec (vector-ref dynamic-projs index)])
+ (let loop ([n dyn-idx] [m method])
+ (if (< n 0)
+ (void)
+ (let* ([p (vector-ref proj-vec n)]
+ [new-m (make-method (p m) id)])
+ (vector-set! new-vec n new-m)
+ (loop (sub1 n) new-m)))
+ (vector-set! int-methods index new-vec))))
+ ;; Under final mode - set extended vtable entry
+ (let ([v (list->vector (vector->list v))])
+ (vector-set! super-methods index method)
+ (vector-set! v (sub1 (vector-length v))
+ ;; Apply current inner contract projection
+ (make-method ((vector-ref inner-projs index) method) id))
+ (vector-set! beta-methods index v))))
+ (unless (vector-ref meth-flags index)
+ (vector-set! meth-flags index (not make-struct:prim)))
+
+ ;; clear out external contracts for methods that are overridden
+ (when wci-neg-extra-arg-vec
+ (vector-set! wci-neg-extra-arg-vec index #f)
+ (hash-remove! wci-neg-acceptors-ht method)))
+ (append replace-augonly-indices replace-final-indices replace-normal-indices
+ refine-augonly-indices refine-final-indices refine-normal-indices)
+ (append override-methods augride-methods)
+ (append override-names augride-names))
+ ;; Update 'augmentable flags:
+ (unless no-method-changes?
+ (for-each (lambda (id)
+ (vector-set! meth-flags (hash-ref method-ht id) 'augmentable))
+ (append overment-names pubment-names))
+ (for-each (lambda (id)
+ (vector-set! meth-flags (hash-ref method-ht id) #t))
+ augride-normal-names))
+ ;; Expand `rename-inner' vector, adding a #f to indicate that
+ ;; no rename-inner function is available, so far
+ (for-each (lambda (id)
+ (let ([index (hash-ref method-ht id)])
+ (let ([v (list->vector (append (vector->list (vector-ref beta-methods index))
+ (list #f)))])
+ ;; Since this starts a new part of the chain, reset the projection.
+ (vector-set! inner-projs index values)
+ (vector-set! beta-methods index v))))
+ augonly-names)
+ ;; Mark final methods:
+ (for-each (lambda (id)
+ (let ([index (hash-ref method-ht id)])
+ (vector-set! meth-flags index 'final)))
+ final-names)
+ ;; Handle interface contracted methods:
+ (for-each (lambda (id)
+ (let ([index (hash-ref method-ht id)]
+ [blame `(class ,name)])
+ ;; Store blame information that will be instantiated later
+ (define ictc-infos (get-interface-contract-info
+ (class-self-interface c) id))
+ (define meth-entry (vector-ref methods index))
+ (define meth (if (pair? meth-entry)
+ (car meth-entry)
+ meth-entry))
+ (vector-set! methods index
+ (list meth
+ ;; Replace #f positive parties w/ this class
+ (replace-ictc-blame ictc-infos #t blame)))))
+ (class-method-ictcs c))
+
+ ;; --- Install serialize info into class --
+ (set-class-serializer!
+ c
+ (cond
+ [(interface-extension? i externalizable<%>)
+ (let ([index (car (get-indices method-ht "???" '(externalize)))])
+ (lambda (obj)
+ (vector ((vector-ref methods index) obj))))]
+ [(and (or deserialize-id
+ (not inspector))
+ (class-serializer super))
+ => (lambda (ss)
+ (lambda (obj)
+ (vector (cons (ss obj)
+ (let loop ([i 0])
+ (if (= i num-fields)
+ null
+ (cons (object-field-ref obj i)
+ (loop (add1 i)))))))))]
+ [else #f]))
+
+ (set-class-fixup!
+ c
+ ;; Used only for non-externalizable:
+ (lambda (o args)
+ (if (pair? args)
+ (begin
+ ((class-fixup super) o (vector-ref (car args) 0))
+ (let loop ([i 0][args (cdr args)])
+ (unless (= i num-fields)
+ (object-field-set! o i (car args))
+ (loop (add1 i) (cdr args)))))
+ (begin
+ ((class-fixup super) o args)
+ (let loop ([i 0])
+ (unless (= i num-fields)
+ (object-field-set! o i (object-field-ref args i))
+ (loop (add1 i))))))))
+
+ ;; --- Install initializer into class ---
+ ;; and create contract-wrapped subclass
+ (define c+ctc
+ (cond
+ [wci-neg-extra-arg-vec
+ (define neg-party (impersonator-prop:get-wrapped-class-neg-party super))
+ (define info (impersonator-prop:get-wrapped-class-info super))
+ (define blame (wrapped-class-info-blame info))
+ (define sub-init-proj-pairs
+ (let loop ([proj-pairs (wrapped-class-info-init-proj-pairs info)])
+ (cond
+ [(null? proj-pairs) '()]
+ [else
+ (define pr (car proj-pairs))
+ (if (member (list-ref pr 0) init-args)
+ (loop (cdr proj-pairs))
+ (cons pr (loop (cdr proj-pairs))))])))
+ (define super-init-proj-pairs (wrapped-class-info-init-proj-pairs info))
+
+ ;; use an init that checks the super contracts on a super call
+ (set-class-init!
+ c
+ (λ (o continue-make-super c inited? leftovers named-args)
+ (define (contract-checking-continue-make-super o c inited?
+ leftovers
+ by-pos-args
+ new-named-args)
+ (check-arg-contracts blame neg-party c
+ super-init-proj-pairs
+ new-named-args)
+ (continue-make-super o c inited?
+ leftovers
+ by-pos-args
+ new-named-args))
+ (init o contract-checking-continue-make-super
+ c inited? leftovers named-args)))
+
+ ;; add properties to the subclass that
+ ;; check the residual external contracts
+ (impersonate-struct
+ c
+
+ set-class-orig-cls! (λ (a b) b)
+
+ impersonator-prop:wrapped-class-neg-party
+ neg-party
+
+ impersonator-prop:wrapped-class-info
+ (wrapped-class-info
+ blame
+ wci-neg-extra-arg-vec
+ wci-neg-acceptors-ht
+ (wrapped-class-info-pos-field-projs info)
+ (wrapped-class-info-neg-field-projs info)
+ sub-init-proj-pairs))]
+ [else
+ (set-class-init! c init)
+ c]))
+
+ ;; -- result is the class, and maybe deserialize-info ---
+ (if deserialize-id
+ (values c+ctc
+ (make-deserialize-info
+ (if (interface-extension? i externalizable<%>)
+ (lambda (args)
+ (let ([o (make-object c)])
+ (send o internalize args)
+ o))
+ (lambda (args)
+ (let ([o (make-object-uninitialized c `(class ,name))])
+ ((class-fixup c) o args)
+ o)))
+ (if (interface-extension? i externalizable<%>)
+ (lambda ()
+ (obj-error 'deserialize
+ "cannot deserialize instance with cycles"
+ #:class-name name))
+ (lambda ()
+ (let ([o (object-make)])
+ (values o
+ (lambda (o2)
+ ((class-fixup c) o o2))))))))
+ (copy-seals super c+ctc)))))))))))))
+
+;; (listof interface?) -> (listof symbol?)
+;; traverse the interfaces and figure out contracted methods
+(define (interfaces->contracted-methods loi)
+ (define immediate-methods
+ (map (λ (ifc) (hash-keys (interface-contracts ifc))) loi))
+ (define super-methods
+ (map (λ (ifc) (interfaces->contracted-methods (interface-supers ifc))) loi))
+ (remove-duplicates (apply append (append immediate-methods super-methods)) eq?))
+
+#|
+An example
+
+(define (c1 x) #t)
+(define (c2 x) #t)
+(define (c3 x) #t)
+(define (c4 x) #t)
+(define (c5 x) #t)
+(define (c6 x) #t)
+(define (c7 x) #t)
+(define (c8 x) #t)
+
+(define i1
+(interface () [x c1]))
+(define i2
+(interface (i1) [x c2]))
+(define i3
+(interface (i1) [x c3]))
+(define i4
+(interface (i2 i3) [x c4]))
+(define i5
+(interface (i3) [x c5]))
+(define i6
+(interface (i2) [x c6]))
+(define i7
+(interface (i4 i5) [x c7]))
+(define i8
+(interface (i6 i7) [x c8]))
+
+(get-interface-contract-info i8 'x)
+
+'((#<procedure:c8> i8 #f i8) (#<procedure:c6> i6 i8 i6)
+(#<procedure:c2> i2 i6 i2) (#<procedure:c1> i1 i2 #f)
+
+(#<procedure:c7> i7 i8 i7) (#<procedure:c4> i4 i7 i4)
+
+(#<procedure:c3> i3 i4 i3)
+
+(#<procedure:c5> i5 i7 i5))
+|#
+;; interface symbol -> (listof (list contract name (or blame #f) (or blame #f)))
+;; traverse hierarchy to find ctc/blame info for a given method
+(define (get-interface-contract-info ifc meth)
+ ;; recur on hierarchy
+ (define super-infos
+ (apply append (map (λ (ifc) (get-interface-contract-info ifc meth))
+ (interface-supers ifc))))
+ ;; deduplicate the infos we get
+ (define dedup-infos
+ (let loop ([infos super-infos])
+ (if (null? infos)
+ '()
+ (cons (car infos)
+ (loop (remove* (list (car infos))
+ (cdr infos)
+ (λ (i1 i2) (eq? (car i1) (car i2)))))))))
+ (define our-ctc (hash-ref (interface-contracts ifc) meth #f))
+ (define our-ctcs (hash-keys (interface-contracts ifc)))
+ (define our-name `(interface ,(interface-name ifc)))
+ (cond ;; if we don't have the contract, the parent's info is fine
+ [(not our-ctc) dedup-infos]
+ ;; if the parent's don't contract it, then it's just our ctc
+ [(null? dedup-infos) (list (list our-ctc our-name #f #f))]
+ ;; our ctc should have a negative party of ourself (for behav. subtyping)
+ [else (cons (list our-ctc our-name #f our-name)
+ ;; replace occurrences of #f positive blame with this interface
+ (map (λ (info)
+ (if (not (caddr info))
+ (list (car info) (cadr info) our-name (cadddr info))
+ info))
+ dedup-infos))]))
+
+;; infos bool blame -> infos
+;; replace either positive or negative parties that are #f with blame
+(define (replace-ictc-blame infos pos? blame)
+ (if pos?
+ (for/list ([info infos])
+ (list (car info) (cadr info) (or (caddr info) blame) (cadddr info)))
+ (for/list ([info infos])
+ (list (car info) (cadr info) (caddr info) (or (cadddr info) blame)))))
+
+(define (check-still-unique name syms what)
+ (let ([ht (make-hasheq)])
+ (for-each (lambda (s)
+ (when (hash-ref ht s
+ (lambda ()
+ (hash-set! ht s #t)
+ #f))
+ (obj-error 'class* (format "external ~a mapped to overlapping keys"
+ what)
+ #:class-name name)))
+ syms)))
+
+(define (get-properties intfs)
+ (if (ormap (lambda (i)
+ (pair? (interface-properties i)))
+ intfs)
+ (let ([ht (make-hash)])
+ ;; Hash on gensym to avoid providing the same property multiple
+ ;; times when it originated from a single interface.
+ (for-each (lambda (i)
+ (for-each (lambda (p)
+ (hash-set! ht (vector-ref p 0) p))
+ (interface-properties i)))
+ intfs)
+ (hash-map ht (lambda (k v) (cons (vector-ref v 1)
+ (vector-ref v 2)))))
+ ;; No properties to add:
+ null))
+
+(define (add-properties struct-type intfs)
+ (let ([props (get-properties intfs)])
+ (if (null? props)
+ struct-type
+ ;; Create a new structure type to house the properties, so
+ ;; that they can't see any fields directly via guards:
+ (let-values ([(struct: make- ? -ref -set!)
+ (make-struct-type 'props struct-type 0 0 #f props #f)])
+ struct:))))
+
+(define-values (prop:object _object? object-ref)
+ (make-struct-type-property 'object 'can-impersonate))
+(define (object? o)
+ (or (_object? o)
+ (wrapped-object? o)))
+(define (object-ref/unwrap o)
+ (cond
+ [(_object? o) (object-ref o)]
+ [(wrapped-object? o) (object-ref/unwrap (wrapped-object-object o))]
+ [else
+ ;; error case
+ (object-ref o)]))
+
+
+
+;;--------------------------------------------------------------------
+;; sealing/unsealing
+;;--------------------------------------------------------------------
+
+;; represents a seal on a class, only for internal use
+;;
+;; sym - the symbol used to identify the particular seal
+;; inst-checker - a function to run when a sealed class is instantiated
+;; init-checker - these three fields respectively are functions to run when
+;; field-checker a sealed class is subclassed and should error when a sealed
+;; method-checker member is added in the subclass
+(struct seal (sym inst-checker init-checker field-checker method-checker)
+ #:transparent)
+
+(define-values (prop:seals has-seals? get-seals)
+ (make-impersonator-property 'class-seals))
+
+(define (class-seal cls seal-sym
+ inits fields methods
+ inst-proc
+ member-proc)
+ (unless (class? cls)
+ (raise-argument-error 'class-seal "class?" cls))
+ (unless (symbol? seal-sym)
+ (raise-argument-error 'class-seal "symbol?" seal-sym))
+ (define (check-unsealed-names val)
+ (unless (and (list? val)
+ (andmap symbol? val))
+ (raise-argument-error 'class-seal "(listof symbol?)" val)))
+ (check-unsealed-names inits)
+ (check-unsealed-names fields)
+ (check-unsealed-names methods)
+ (unless (procedure-arity-includes? inst-proc 1)
+ (raise-argument-error 'class-seal
+ "(procedure-arity-includes/c 1)" inst-proc))
+ (unless (procedure-arity-includes? member-proc 2)
+ (raise-argument-error 'class-seal
+ "(procedure-arity-includes/c 2)" member-proc))
+
+ (define new-seal
+ (seal seal-sym
+ inst-proc
+ (make-seal-checker member-proc cls inits)
+ (make-seal-checker member-proc cls fields)
+ (make-seal-checker member-proc cls methods)))
+ (define seals (cons new-seal
+ (or (and (has-seals? cls) (get-seals cls)) null)))
+ ;; impersonate to avoid the cost of creating a class wrapper
+ (impersonate-struct cls
+ class-object? #f ; just here as a witness
+ set-class-object?! #f ; also need this witness
+ prop:seals seals))
+
+;; make-seal-checker : procedure? class? (listof symbol?)
+;; -> (listof symbol?) -> void?
+;; constructs a checker function parameterized over the user-provided
+;; checker procedure and the list of unsealed names
+(define ((make-seal-checker proc cls unsealed) actual)
+ (define sealed-actuals (remove* unsealed actual))
+ (unless (null? sealed-actuals)
+ (proc cls sealed-actuals)))
+
+(define (class-unseal cls sym wrong-key-proc)
+ (unless (class? cls)
+ (raise-argument-error 'class-seal "class?" cls))
+ (unless (symbol? sym)
+ (raise-argument-error 'class-seal "symbol?" seal-sym))
+
+ (define old-seals (and (has-seals? cls) (get-seals cls)))
+ (define has-seal-with-sym?
+ (and old-seals
+ (for/or ([old-seal (in-list old-seals)])
+ (eq? sym (seal-sym old-seal)))))
+ (unless has-seal-with-sym?
+ (wrong-key-proc cls))
+ (define new-seals
+ (remove sym (get-seals cls)
+ (λ (sym sl) (eq? sym (seal-sym sl)))))
+ (impersonate-struct cls
+ class-object? #f
+ set-class-object?! #f
+ prop:seals new-seals))
+
+;; copy-seals : class? class? -> class?
+;; Copy the seal properties from one class to another
+(define (copy-seals cls1 cls2)
+ (if (has-seals? cls1)
+ (impersonate-struct cls2
+ class-object? #f
+ set-class-object?! #f
+ prop:seals (get-seals cls1))
+ cls2))
+
+;;--------------------------------------------------------------------
+;; interfaces
+;;--------------------------------------------------------------------
+
+;; >> Simplistic implementation for now <<
+
+(define-for-syntax do-interface
+ (lambda (stx m-stx)
+ (syntax-case m-stx ()
+ [((interface-expr ...) ([prop prop-val] ...) var ...)
+ (let ([name (syntax-local-infer-name stx)])
+ (define-values (vars ctcs)
+ (for/fold ([vars '()] [ctcs '()])
+ ([v (syntax->list #'(var ...))])
+ (syntax-case v ()
+ [id
+ (identifier? #'id)
+ (values (cons #'id vars) (cons #f ctcs))]
+ [(id ctc)
+ (identifier? #'id)
+ (values (cons #'id vars) (cons #'ctc ctcs))]
+ [_ (raise-syntax-error #f "not an identifier or identifier-contract pair"
+ stx v)])))
+ (let ([dup (check-duplicate-identifier vars)])
+ (when dup
+ (raise-syntax-error #f
+ "duplicate name"
+ stx
+ dup)))
+ (with-syntax ([name (datum->syntax #f name #f)]
+ [(var ...) (map localize vars)]
+ [((v c) ...) (filter (λ (p) (cadr p)) (map list vars ctcs))])
+ (class-syntax-protect
+ (syntax/loc stx
+ (compose-interface
+ 'name
+ (list interface-expr ...)
+ `(var ...)
+ (make-immutable-hash (list (cons 'v c) ...))
+ (list prop ...)
+ (list prop-val ...))))))])))
+
+(define-syntax (_interface stx)
+ (syntax-case stx ()
+ [(_ (interface-expr ...) var ...)
+ (do-interface stx #'((interface-expr ...) () var ...))]))
+
+(define-syntax (interface* stx)
+ (syntax-case stx ()
+ [(_ (interface-expr ...) ([prop prop-val] ...) var ...)
+ (do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))]
+ [(_ (interface-expr ...) (prop+val ...) var ...)
+ (for-each (lambda (p+v)
+ (syntax-case p+v ()
+ [(p v) (void)]
+ [_ (raise-syntax-error #f
+ "expected `[<prop-expr> <val-expr>]'"
+ stx
+ p+v)]))
+ (syntax->list #'(prop+val ...)))]
+ [(_ (interface-expr ...) prop+vals . _)
+ (raise-syntax-error #f
+ "expected `([<prop-expr> <val-expr>] ...)'"
+ stx
+ #'prop+vals)]))
+
+(define-struct interface
+ (name ; symbol
+ supers ; (listof interface)
+ [all-implemented ; hash-table: interface -> #t
+ #:mutable]
+ public-ids ; (listof symbol) (in any order?!?)
+ contracts ; (hashof symbol? contract?)
+ [class ; (union #f class) -- means that anything implementing
+ #:mutable] ; this interface must be derived from this class
+ properties) ; (listof (vector gensym prop val))
+ #:inspector insp)
+
+(define (compose-interface name supers vars ctcs props vals)
+ (for-each
+ (lambda (intf)
+ (unless (interface? intf)
+ (obj-error 'interface
+ "superinterface expression result is not an interface"
+ "result" intf
+ #:intf-name name)))
+ supers)
+ (for-each
+ (lambda (p)
+ (unless (struct-type-property? p)
+ (obj-error 'interface
+ "property expression result is not a property"
+ "result" p
+ #:intf-name name)))
+ props)
+ (let ([ht (make-hasheq)])
+ (for-each
+ (lambda (var)
+ (hash-set! ht var #t))
+ vars)
+ ;; Check that vars don't already exist in supers:
+ (for-each
+ (lambda (super)
+ (for-each
+ (lambda (var)
+ (when (and (hash-ref ht var #f)
+ (not (hash-ref ctcs var #f)))
+ (obj-error 'interface "variable already in superinterface"
+ "variable name" (as-write var)
+ (and (interface-name super) "already in") (as-write (interface-name super))
+ #:intf-name name)))
+ (interface-public-ids super)))
+ supers)
+ ;; merge properties:
+ (let ([prop-ht (make-hash)])
+ ;; Hash on gensym to avoid providing the same property multiple
+ ;; times when it originated from a single interface.
+ (for-each (lambda (i)
+ (for-each (lambda (p)
+ (hash-set! prop-ht (vector-ref p 0) p))
+ (interface-properties i)))
+ supers)
+ (for-each (lambda (p v)
+ (let ([g (gensym)])
+ (hash-set! prop-ht g (vector g p v))))
+ props vals)
+ ;; Check for [conflicting] implementation requirements
+ (let ([class (get-implement-requirement supers 'interface #:intf-name name)]
+ [interface-make (if name
+ (make-naming-constructor struct:interface
+ name
+ "interface")
+ make-interface)])
+ ;; Add supervars to table:
+ (for-each
+ (lambda (super)
+ (for-each
+ (lambda (var) (hash-set! ht var #t))
+ (interface-public-ids super)))
+ supers)
+ ;; Done
+ (let* ([new-ctcs (for/hash ([(k v) (in-hash ctcs)])
+ (values k (coerce-contract 'interface v)))]
+ [i (interface-make name supers #f (hash-map ht (lambda (k v) k))
+ new-ctcs class (hash-map prop-ht (lambda (k v) v)))])
+ (setup-all-implemented! i)
+ i)))))
+
+;; setup-all-implemented! : interface -> void
+;; Creates the hash table for all implemented interfaces
+(define (setup-all-implemented! i)
+ (let ([ht (make-hasheq)])
+ (hash-set! ht i #t)
+ (for-each (lambda (si)
+ (hash-for-each
+ (interface-all-implemented si)
+ (lambda (k v)
+ (hash-set! ht k #t))))
+ (interface-supers i))
+ (set-interface-all-implemented! i ht)))
+
+(define (get-implement-requirement interfaces where
+ #:class-name [class-name #f]
+ #:intf-name [intf-name #f])
+ (let loop ([class #f]
+ [supers interfaces])
+ (if (null? supers)
+ class
+ (let ([c (interface-class (car supers))])
+ (loop
+ (cond
+ [(not c) class]
+ [(not class) c]
+ [(subclass? c class) class]
+ [(subclass? class c) c]
+ [else
+ (obj-error
+ where
+ "conflicting class implementation requirements in superinterfaces"
+ #:class-name class-name
+ #:intf-name intf-name)])
+ (cdr supers))))))
+
+;;--------------------------------------------------------------------
+;; object%
+;;--------------------------------------------------------------------
+
+(define (make-naming-constructor type name prefix)
+ (define (writeer obj port mode)
+ (write-string "#<" port)
+ (when prefix
+ (write-string prefix port)
+ (write-string ":" port))
+ (write-string (symbol->string name) port)
+ (write-string ">" port))
+ (define props (list (cons prop:custom-write writeer)))
+ (define-values (struct: make- ? -accessor -mutator)
+ (make-struct-type name type 0 0 #f props insp))
+ make-)
+
+(define not-all-visible (gensym 'not-all-visible))
+(define (inspectable-struct->vector v)
+ (define vec (struct->vector v not-all-visible))
+ (and (for/and ([elem (in-vector vec)])
+ (not (eq? elem not-all-visible)))
+ vec))
+
+; Even though equality on objects is morally just struct equality, we have to reimplement it here
+; because of the way class contracts work. Every time a class contract is applied, it creates a new
+; class, which in turn creates a new struct. This breaks equal? on objects, since two structs of
+; different types are never equal? (without a custom prop:equal+hash), even if one is a subtype of the
+; other. Therefore, we need to emulate what the behavior of equal? would have been if class contracts
+; didn’t create new struct types. (This can go away if class/c is ever rewritten to use chaperones.)
+(define (object-equal? obj-a obj-b recur)
+ (and (equal? (object-ref obj-a) (object-ref obj-b))
+ (let ([vec-a (inspectable-struct->vector obj-a)])
+ (and vec-a (let ([vec-b (inspectable-struct->vector obj-b)])
+ (and vec-b (for/and ([elem-a (in-vector vec-a 1)]
+ [elem-b (in-vector vec-b 1)])
+ (recur elem-a elem-b))))))))
+(define (object-hash-code obj recur)
+ (let ([vec (inspectable-struct->vector obj)])
+ (if vec
+ (recur (vector (object-ref obj) vec))
+ (eq-hash-code obj))))
+
+(define object<%> ((make-naming-constructor struct:interface 'interface:object% #f)
+ 'object% null #f null (make-immutable-hash) #f null))
+(setup-all-implemented! object<%>)
+(define object% ((make-naming-constructor struct:class 'object% "class")
+ 'object%
+ 0 (vector #f)
+ object<%>
+ void ; never inspectable
+ #f ; this is for the inspector on the object
+
+ 0 (make-hasheq) null null null
+ #f
+ (vector) (vector) (vector) (vector) (vector)
+
+ (vector) (vector) (vector)
+
+ 0 0 (make-hasheq) null null
+
+ 'struct:object object? 'make-object
+ 'field-ref-not-needed 'field-set!-not-needed
+
+ null
+ 'normal
+
+ (lambda (this super-init si_c si_inited? si_leftovers args)
+ (unless (null? args)
+ (unused-args-error this args))
+ (void))
+
+ #f
+ (lambda (obj) #(())) ; serialize
+ (lambda (obj args) (void)) ; deserialize-fixup
+
+ #f ; no chaperone to guard against unsafe-undefined
+
+ #t)) ; no super-init
+
+(vector-set! (class-supers object%) 0 object%)
+(set-class-orig-cls! object% object%)
+(let*-values ([(struct:obj make-obj obj? -get -set!)
+ (make-struct-type 'object #f 0 0 #f
+ (list (cons prop:object object%)
+ (cons prop:equal+hash
+ (list object-equal?
+ object-hash-code
+ object-hash-code)))
+ #f)])
+ (set-class-struct:object! object% struct:obj)
+ (set-class-make-object! object% make-obj))
+(set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
+
+(set-interface-class! object<%> object%)
+
+;;--------------------------------------------------------------------
+;; instantiation
+;;--------------------------------------------------------------------
+
+(define-syntax (new stx)
+ (syntax-case stx ()
+ [(_ cls (id arg) ...)
+ (andmap identifier? (syntax->list (syntax (id ...))))
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (instantiate cls () (id arg) ...)))]
+ [(_ cls (id arg) ...)
+ (for-each (lambda (id)
+ (unless (identifier? id)
+ (raise-syntax-error 'new "expected identifier" stx id)))
+ (syntax->list (syntax (id ...))))]
+ [(_ cls pr ...)
+ (for-each
+ (lambda (pr)
+ (syntax-case pr ()
+ [(x y) (void)]
+ [else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
+ (syntax->list (syntax (pr ...))))]))
+
+(define ((make-object/proc blame) class . args)
+ (do-make-object blame class args null))
+
+(define-syntax make-object
+ (make-set!-transformer
+ (lambda (stx)
+ (syntax-case stx ()
+ [id
+ (identifier? #'id)
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (make-object/proc (current-contract-region))))]
+ [(_ class arg ...)
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (do-make-object
+ (current-contract-region)
+ class (list arg ...) (list))))]
+ [(_) (raise-syntax-error 'make-object "expected class" stx)]))))
+
+(define-syntax (instantiate stx)
+ (syntax-case stx ()
+ [(form class (arg ...) . x)
+ (with-syntax ([orig-stx stx])
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (-instantiate do-make-object orig-stx #t (class) (list arg ...) . x))))]))
+
+;; Helper; used by instantiate and super-instantiate
+(define-syntax -instantiate
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ do-make-object orig-stx first? (maker-arg ...) args (kw arg) ...)
+ (andmap identifier? (syntax->list (syntax (kw ...))))
+ (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))]
+ [(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)])
+ (class-syntax-protect
+ (syntax/loc stx
+ (do-make-object blame ...
+ maker-arg ...
+ args
+ (list (cons `kw arg)
+ ...)))))]
+ [(_ super-make-object orig-stx first? (make-arg ...) args kwarg ...)
+ ;; some kwarg must be bad:
+ (for-each (lambda (kwarg)
+ (syntax-case kwarg ()
+ [(kw arg)
+ (identifier? (syntax kw))
+ 'ok]
+ [(kw arg)
+ (raise-syntax-error
+ #f
+ "by-name argument does not start with an identifier"
+ (syntax orig-stx)
+ kwarg)]
+ [_else
+ (raise-syntax-error
+ #f
+ "ill-formed by-name argument"
+ (syntax orig-stx)
+ kwarg)]))
+ (syntax->list (syntax (kwarg ...))))])))
+
+(define (alist->sexp alist)
+ (map (lambda (pair) (list (car pair) (cdr pair))) alist))
+
+;; class blame -> class
+;; takes a class and concretize interface ctc methods
+(define (fetch-concrete-class cls blame)
+ (cond [(null? (class-method-ictcs cls)) cls]
+ [(and (class-ictc-classes cls)
+ (hash-ref (class-ictc-classes cls) blame #f))
+ => values]
+ [else
+ ;; if there are contracted methods to concretize, do so
+ (let* ([name (class-name cls)]
+ [ictc-meths (class-method-ictcs cls)]
+ [method-width (class-method-width cls)]
+ [method-ht (class-method-ht cls)]
+ [meths (if (null? ictc-meths)
+ (class-methods cls)
+ (make-vector method-width))]
+ [field-pub-width (class-field-pub-width cls)]
+ [field-ht (class-field-ht cls)]
+ [class-make (if name
+ (make-naming-constructor struct:class name "class")
+ make-class)]
+ [c (class-make name
+ (class-pos cls)
+ (list->vector (vector->list (class-supers cls)))
+ (class-self-interface cls)
+ void ;; No inspecting
+ (class-obj-inspector cls)
+
+ method-width
+ method-ht
+ (class-method-ids cls)
+ null
+ null
+
+ #f
+
+ meths
+ (class-super-methods cls)
+ (class-int-methods cls)
+ (class-beta-methods cls)
+ (class-meth-flags cls)
+
+ (class-inner-projs cls)
+ (class-dynamic-idxs cls)
+ (class-dynamic-projs cls)
+
+ (class-field-width cls)
+ field-pub-width
+ field-ht
+ (class-field-ids cls)
+ (class-all-field-ids cls)
+
+ 'struct:object 'object? 'make-object
+ 'field-ref 'field-set!
+
+ (class-init-args cls)
+ (class-init-mode cls)
+ (class-init cls)
+
+ (class-orig-cls cls)
+ #f #f ; serializer is never set
+
+ (class-check-undef? cls)
+ #f)]
+ [obj-name (if name
+ (string->symbol (format "wrapper-object:~a" name))
+ 'object)])
+
+ (vector-set! (class-supers c) (class-pos c) c)
+
+ ;; --- Make the new object struct ---
+ (let-values ([(struct:object object-make object? object-field-ref object-field-set!)
+ (make-struct-type obj-name
+ (class-struct:object cls)
+ 0 ;; No init fields
+ 0 ;; No new fields in this class replacement
+ unsafe-undefined
+ ;; Map object property to class:
+ (list (cons prop:object c))
+ (class-obj-inspector cls))])
+ (set-class-struct:object! c struct:object)
+ (set-class-object?! c object?)
+ (set-class-make-object! c object-make)
+ (set-class-field-ref! c object-field-ref)
+ (set-class-field-set!! c object-field-set!))
+
+ ;; Don't concretize if all concrete
+ (unless (null? ictc-meths)
+ ;; First, fill up since we're empty
+ (vector-copy! meths 0 (class-methods cls))
+ ;; Then apply the projections to get the concrete methods
+ (for ([m (in-list ictc-meths)])
+ (define index (hash-ref method-ht m))
+ (define entry (vector-ref meths index))
+ (define meth (car entry))
+ (define ictc-infos (replace-ictc-blame (cadr entry) #f blame))
+ (define wrapped-meth (concretize-ictc-method m meth ictc-infos))
+ (vector-set! meths index wrapped-meth)))
+
+ ;; initialize if not yet initialized
+ (unless (class-ictc-classes cls)
+ (set-class-ictc-classes! cls (make-weak-hasheq)))
+
+ ;; cache the concrete class
+ (hash-set! (class-ictc-classes cls) blame c)
+ (copy-seals cls c))]))
+
+;; name method info -> method
+;; appropriately wraps the method with interface contracts
+(define (concretize-ictc-method m meth info)
+ (for/fold ([meth meth])
+ ([info (in-list info)])
+ (define ctc (car info))
+ (define pos-blame (caddr info))
+ (define neg-blame (cadddr info))
+ (contract ctc meth pos-blame neg-blame m #f)))
+
+(define (make-object-uninitialized class blame)
+ (do-make-object blame class 'uninit 'uninit))
+
+(define (do-make-object blame class by-pos-args named-args)
+ (cond
+ [(impersonator-prop:has-wrapped-class-neg-party? class)
+ (define the-info (impersonator-prop:get-wrapped-class-info class))
+ (define neg-party (impersonator-prop:get-wrapped-class-neg-party class))
+ (define unwrapped-o
+ (do-make-object/real-class blame class by-pos-args named-args
+ (wrapped-class-info-blame the-info)
+ neg-party
+ (wrapped-class-info-init-proj-pairs the-info)))
+ (wrapped-object
+ unwrapped-o
+ (wrapped-class-info-neg-extra-arg-vec the-info)
+ (wrapped-class-info-pos-field-projs the-info)
+ (wrapped-class-info-neg-field-projs the-info)
+ neg-party)]
+ [(class? class)
+ (do-make-object/real-class blame class by-pos-args named-args #f #f '())]
+ [else
+ (raise-argument-error 'instantiate "class?" class)]))
+
+(define (do-make-object/real-class blame class by-pos-args named-args
+ wrapped-blame wrapped-neg-party init-proj-pairs)
+ ;; make sure the class isn't abstract
+ (unless (null? (class-abstract-ids class))
+ (obj-error 'instantiate
+ "cannot instantiate class with abstract methods"
+ "class" class
+ "abstract methods" (as-write-list (class-abstract-ids class))))
+ ;; if the class is sealed, run all sealing error procedures
+ ;; usually, only running the first one is necessary since these are
+ ;; expected to be error-reporting procedures.
+ (when (has-seals? class)
+ (for ([seal (in-list (get-seals class))])
+ ((seal-inst-checker seal) class)))
+ ;; Generate correct class by concretizing methods w/interface ctcs
+ (define concrete-class (fetch-concrete-class class blame))
+ (define o ((class-make-object concrete-class)))
+ (unless (eq? by-pos-args 'uninit)
+ (continue-make-object o concrete-class by-pos-args named-args #t
+ wrapped-blame wrapped-neg-party init-proj-pairs))
+ o)
+
+(define (get-field-alist obj)
+ (map (lambda (id) (cons id (get-field/proc id obj)))
+ (field-names obj)))
+
+(define (continue-make-object o c by-pos-args named-args explict-named-args?
+ wrapped-blame wrapped-neg-party init-proj-pairs)
+ (let ([by-pos-only? (not (class-init-args c))])
+ ;; When a superclass has #f for init-args (meaning "by-pos args with no names"),
+ ;; some propagated named args may have #f keys; move them to by-position args.
+ (let-values ([(by-pos-args named-args)
+ (if by-pos-only?
+ (let ([l (filter (lambda (x) (not (car x))) named-args)])
+ (if (pair? l)
+ (values (append by-pos-args (map cdr l))
+ (filter car named-args))
+ (values by-pos-args named-args)))
+ (values by-pos-args named-args))])
+ ;; Primitive class with by-pos arguments?
+ (when by-pos-only?
+ (unless (null? named-args)
+ (if explict-named-args?
+ (obj-error
+ 'instantiate
+ "class has only by-position initializers, but given by-name arguments"
+ "arguments" (as-lines (make-named-arg-string named-args))
+ #:class-name (class-name c))
+ ;; If args were implicit from subclass, should report as unused:
+ (unused-args-error o named-args))))
+ ;; Merge by-pos into named args:
+ (let* ([named-args (if (not by-pos-only?)
+ ;; Normal merge
+ (do-merge by-pos-args (class-init-args c) c named-args by-pos-args c)
+ ;; Non-merge for by-position initializers
+ by-pos-args)]
+ [leftovers (if (not by-pos-only?)
+ (get-leftovers named-args (class-init-args c))
+ null)])
+ ;; In 'list mode, make sure no by-name arguments are left over
+ (when (eq? 'list (class-init-mode c))
+ (unless (or (null? leftovers)
+ (not (ormap car leftovers)))
+ (unused-args-error o (filter car leftovers))))
+ (unless (and (eq? c object%)
+ (null? named-args))
+ (let ([named-args (check-arg-contracts wrapped-blame wrapped-neg-party
+ c init-proj-pairs named-args)])
+ (let ([inited? (box (class-no-super-init? c))])
+ ;; ----- Execute the class body -----
+ ((class-init c)
+ o
+ continue-make-super
+ c inited? leftovers ; merely passed through to continue-make-super
+ named-args)
+ (unless (unbox inited?)
+ (obj-error 'instantiate
+ "superclass initialization not invoked by initialization"
+ #:class-name (class-name c))))))))))
+
+(define (continue-make-super o c inited? leftovers by-pos-args new-named-args)
+ (when (unbox inited?)
+ (obj-error 'instantiate
+ "superclass already initialized by class initialization"
+ #:class-name (class-name c)))
+ (set-box! inited? #t)
+ (let ([named-args (if (eq? 'list (class-init-mode c))
+ ;; all old args must have been used up
+ new-named-args
+ ;; Normal mode: merge leftover keyword-based args with new ones
+ (append
+ new-named-args
+ leftovers))])
+ (continue-make-object o
+ (vector-ref (class-supers c) (sub1 (class-pos c)))
+ by-pos-args
+ named-args
+ (pair? new-named-args)
+ #f #f '())))
+
+(define (do-merge al nl ic named-args by-pos-args c)
+ (cond
+ [(null? al) named-args]
+ [(null? nl)
+ ;; continue mapping with superclass init args, if allowed
+ (let ([super (and (eq? 'normal (class-init-mode ic))
+ (positive? (class-pos ic))
+ (vector-ref (class-supers ic) (sub1 (class-pos ic))))])
+ (cond
+ [super
+ (if (class-init-args super)
+ (do-merge al (class-init-args super) super named-args by-pos-args c)
+ ;; Like 'list mode:
+ (append (map (lambda (x) (cons #f x)) al)
+ named-args))]
+ [(eq? 'list (class-init-mode ic))
+ ;; All unconsumed named-args must have #f
+ ;; "name"s, otherwise an error is raised in
+ ;; the leftovers checking.
+ (if (null? al)
+ named-args
+ (append (map (lambda (x) (cons #f x)) al)
+ named-args))]
+ [else
+ (obj-error 'instantiate
+ "too many initialization arguments"
+ "arguments" (as-lines (make-pos-arg-string by-pos-args))
+ #:class-name (class-name c))]))]
+ [else (cons (cons (car nl) (car al))
+ (do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))]))
+
+(define (get-leftovers l names)
+ (cond
+ [(null? l) null]
+ [(memq (caar l) names)
+ (get-leftovers (cdr l) (remq (caar l) names))]
+ [else (cons (car l) (get-leftovers (cdr l) names))]))
+
+(define (extract-arg class-name name arguments default)
+ (if (symbol? name)
+ ;; Normal mode
+ (let ([a (assq name arguments)])
+ (cond
+ [a (cdr a)]
+ [default (default)]
+ [else (missing-argument-error class-name name)]))
+ ;; By-position mode
+ (cond
+ [(< name (length arguments))
+ (cdr (list-ref arguments name))]
+ [default (default)]
+ [else (obj-error 'instantiate "too few initialization arguments")])))
+
+(define (extract-rest-args skip arguments)
+ (if (< skip (length arguments))
+ (map cdr (list-tail arguments skip))
+ null))
+
+(define (make-pos-arg-string args)
+ (let ([len (length args)])
+ (apply string-append
+ (map (lambda (a)
+ (format " ~e" a))
+ args))))
+
+(define (make-named-arg-string args)
+ (apply
+ string-append
+ (let loop ([args args][count 0])
+ (cond
+ [(null? args) null]
+ [(= count 3) '("\n ...")]
+ [else (let ([rest (loop (cdr args) (add1 count))])
+ (cons (format "\n [~a ~e]"
+ (caar args)
+ (cdar args))
+ rest))]))))
+
+(define (unused-args-error this args)
+ (let ([arg-string (make-named-arg-string args)])
+ (obj-error 'instantiate "unused initialization arguments"
+ "unused arguments" (as-lines arg-string)
+ #:class-name (class-name (object-ref/unwrap this))
+ #:which-class "instantiated ")))
+
+(define (missing-argument-error class-name name)
+ (obj-error 'instantiate
+ "no argument for required init variable"
+ "init variable name" (as-write name)
+ #:class-name class-name
+ #:which-class "instantiated "))
+
+;;--------------------------------------------------------------------
+;; methods and fields
+;;--------------------------------------------------------------------
+
+(define-syntaxes (send send/apply send/keyword-apply)
+ (let ()
+
+ (define (do-method stx form obj name args rest-arg? kw-args)
+ (with-syntax ([(sym method receiver)
+ (generate-temporaries (syntax (1 2 3)))]
+ [(kw-arg-tmp) (generate-temporaries '(kw-vals-x))])
+ (define kw-args/var (and kw-args
+ (list (car kw-args) #'kw-arg-tmp)))
+ (define arg-list '())
+ (define let-bindings '())
+ (for ([x (in-list (if (list? args)
+ args
+ (syntax->list args)))])
+ (cond
+ [(keyword? (syntax-e x))
+ (set! arg-list (cons x arg-list))]
+ [else
+ (define var (car (generate-temporaries '(send-arg))))
+ (set! arg-list (cons var arg-list))
+ (set! let-bindings (cons #`[#,var #,x] let-bindings))]))
+ (set! arg-list (reverse arg-list))
+ (set! let-bindings (reverse let-bindings))
+
+ (class-syntax-protect
+ (syntax-property
+ (quasisyntax/loc stx
+ (let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
+ [(receiver) (unsyntax obj)]
+ [(method) (find-method/who '(unsyntax form) receiver sym)])
+ (let (#,@(if kw-args
+ (list #`[kw-arg-tmp #,(cadr kw-args)])
+ (list))
+ #,@let-bindings)
+ (unsyntax
+ (make-method-call-to-possibly-wrapped-object
+ stx kw-args/var arg-list rest-arg?
+ #'sym #'method #'receiver
+ (quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym)))))))
+ 'feature-profile:send-dispatch #t))))
+
+ (define (core-send apply? kws?)
+ (lambda (stx)
+ (syntax-case stx ()
+ [(form obj name . args)
+ (identifier? (syntax name))
+ (if (stx-list? (syntax args))
+ ;; (send obj name arg ...) or (send/apply obj name arg ...)
+ (do-method stx #'form #'obj #'name
+ (if kws? (cddr (syntax->list #'args)) #'args)
+ apply?
+ (and kws?
+ (let ([l (syntax->list #'args)])
+ (list (car l) (cadr l)))))
+ (if apply?
+ ;; (send/apply obj name arg ... . rest)
+ (raise-syntax-error
+ #f "bad syntax (illegal use of `.')" stx)
+ ;; (send obj name arg ... . rest)
+ (do-method stx #'form #'obj #'name
+ (flatten-args #'args) #t #f)))]
+ [(form obj name . args)
+ (raise-syntax-error
+ #f "method name is not an identifier" stx #'name)]
+ [(form obj)
+ (raise-syntax-error
+ #f "expected a method name" stx)])))
+
+ (define (send/keyword-apply stx)
+ (syntax-case stx ()
+ [(form obj name)
+ (identifier? (syntax name))
+ (raise-syntax-error #f "missing expression for list of keywords" stx)]
+ [(form obj name a)
+ (identifier? (syntax name))
+ (raise-syntax-error #f "missing expression for list of keyword arguments" stx)]
+ [else ((core-send #t #t) stx)]))
+
+ (values
+ ;; send
+ (core-send #f #f)
+ ;; send/apply
+ (core-send #t #f)
+ ;; send/keyword-apply
+ send/keyword-apply)))
+
+(define dynamic-send
+ (make-keyword-procedure
+ (lambda (kws kw-vals obj method-name . args)
+ (unless (object? obj) (raise-argument-error 'dynamic-send "object?" obj))
+ (unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name))
+ (define mtd (find-method/who 'dynamic-send obj method-name))
+ (cond
+ [(wrapped-object? obj)
+ (if mtd
+ (keyword-apply mtd kws kw-vals
+ (wrapped-object-neg-party obj)
+ (wrapped-object-object obj)
+ args)
+ (keyword-apply dynamic-send kws kw-vals
+ (wrapped-object-object obj)
+ method-name
+ args))]
+ [else
+ (keyword-apply mtd kws kw-vals obj args)]))))
+
+;; imperative chained send
+(define-syntax (send* stx)
+ (syntax-case stx ()
+ [(form obj clause ...)
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (let* ([o obj])
+ (unsyntax-splicing
+ (map
+ (lambda (clause-stx)
+ (syntax-case clause-stx ()
+ [(meth . args)
+ (quasisyntax/loc stx
+ (send o meth . args))]
+ [_ (raise-syntax-error
+ #f "bad method call" stx clause-stx)]))
+ (syntax->list (syntax (clause ...))))))))]))
+
+;; functional chained send
+(define-syntax (send+ stx)
+ (define-syntax-class send-clause
+ #:description "method clause"
+ (pattern [name:id . args]))
+ (syntax-parse stx
+ [(_ obj:expr clause-0:send-clause clause:send-clause ...)
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (let ([o (send obj clause-0.name . clause-0.args)])
+ (send+ o clause ...))))]
+ [(_ obj:expr) (class-syntax-protect
+ (syntax/loc stx obj))]))
+
+;; find-method/who : symbol[top-level-form/proc-name]
+;; any[object]
+;; symbol[method-name]
+;; -> method-proc
+;; returns the method's procedure
+
+(define (find-method/who who in-object name)
+ (cond
+ [(object-ref in-object #f) ; non-#f result implies `_object?`
+ => (lambda (cls)
+ (define mth-idx (hash-ref (class-method-ht cls) name #f))
+ (if mth-idx
+ (vector-ref (class-methods cls) mth-idx)
+ (no-such-method who name cls)))]
+ [(wrapped-object? in-object)
+ (define cls
+ (let loop ([obj in-object])
+ (cond
+ [(wrapped-object? obj) (loop (wrapped-object-object obj))]
+ [else
+ (object-ref obj #f)])))
+ (define mth-idx (hash-ref (class-method-ht cls) name #f))
+ (unless mth-idx (no-such-method who name (object-ref in-object)))
+ (vector-ref (wrapped-object-neg-extra-arg-vec in-object) mth-idx)]
+ [else
+ (obj-error who "target is not an object"
+ "target" in-object
+ "method name" (as-write name))]))
+
+(define (no-such-method who name cls)
+ (obj-error who
+ "no such method"
+ "method name" (as-write name)
+ #:class-name (class-name cls)))
+
+(define-values (make-class-field-accessor make-class-field-mutator)
+ (let ()
+ (define (check-and-get-proc who class name get?)
+ (unless (class? class)
+ (raise-argument-error who "class?" class))
+ (unless (symbol? name)
+ (raise-argument-error who "symbol?" name))
+ (define field-info-external-X (if get? field-info-external-ref field-info-external-set!))
+ (define wrapped-class-info-X-field-projs
+ (if get?
+ wrapped-class-info-pos-field-projs
+ wrapped-class-info-neg-field-projs))
+ (define (get-accessor)
+ (field-info-external-X
+ (hash-ref (class-field-ht class) name
+ (lambda ()
+ (obj-error who "no such field"
+ "field-name" (as-write name)
+ #:class-name (class-name class))))))
+ (cond
+ [(impersonator-prop:has-wrapped-class-neg-party? class)
+ (define the-info (impersonator-prop:get-wrapped-class-info class))
+ (define projs (hash-ref (wrapped-class-info-X-field-projs the-info) name #f))
+ (define np (impersonator-prop:get-wrapped-class-neg-party class))
+ (cond
+ [projs
+ (if get?
+ (let loop ([projs projs])
+ (cond
+ [(pair? projs)
+ (define f-rest (loop (cdr projs)))
+ (define f-this (car projs))
+ (λ (val) ((f-this (f-rest val)) np))]
+ [else projs]))
+ (let loop ([projs projs])
+ (cond
+ [(pair? projs)
+ (define f-rest (loop (cdr projs)))
+ (define f-this (car projs))
+ (λ (o val) ((f-this (f-rest o val)) np))]
+ [else projs])))]
+ [else (get-accessor)])]
+ [else
+ (get-accessor)]))
+ (values (λ (class name)
+ (define ref (check-and-get-proc 'class-field-accessor class name #t))
+ (λ (o)
+ (cond
+ [(_object? o)
+ (ref o)]
+ [(wrapped-object? o)
+ (ref (wrapped-object-object o))]
+ [else
+ (raise-argument-error 'class-field-accessor "object?" o)])))
+ (λ (class name)
+ (define setter! (check-and-get-proc 'class-field-mutator class name #f))
+ (λ (o v)
+ (cond
+ [(_object? o)
+ (setter! o v)]
+ [(wrapped-object? o)
+ (setter! (unwrap-object o) v)]
+ [else
+ (raise-argument-error 'class-field-mutator "object?" o)]))))))
+
+(define-struct generic (name applicable))
+
+;; Internally, make-generic comes from the struct def.
+;; Externally, make-generic is the following procedure.
+;; The extra `let' gives it the right name.
+(define make-generic/proc
+ (let ([make-generic
+ (lambda (class name)
+ (unless (or (class? class) (interface? class))
+ (raise-argument-error 'make-generic "(or/c class? interface?)" class))
+ (unless (symbol? name)
+ (raise-argument-error 'make-generic "symbol?" name))
+ (make-generic
+ name
+ (if (interface? class)
+ (let ([intf class])
+ (unless (method-in-interface? name intf)
+ (obj-error 'make-generic "no such method"
+ "method name" (as-write name)
+ #:intf-name (interface-name intf)))
+ (lambda (obj)
+ (unless (is-a? obj intf)
+ (obj-error
+ (string->symbol (format "generic:~a" name))
+ "target is not an instance of the generic's interface"
+ "target" obj
+ #:intf-name (interface-name intf)))
+ (find-method/who 'make-generic obj name)))
+ (let* ([pos (hash-ref (class-method-ht class) name
+ (lambda ()
+ (obj-error 'make-generic "no such method"
+ "method name" (as-write name)
+ #:class-name (class-name class))))]
+ [instance? (class-object? (class-orig-cls class))]
+ [fail (λ (obj)
+ (obj-error
+ (string->symbol (format "generic:~a" name))
+ "target is not an instance of the generic's class"
+ "target" obj
+ #:class-name (class-name class)))]
+ [dynamic-generic
+ (lambda (obj)
+ (cond
+ [(wrapped-object? obj)
+ (vector-ref (wrapped-object-neg-extra-arg-vec obj) pos)]
+ [(instance? obj)
+ (vector-ref (class-methods (object-ref obj)) pos)]
+ [else (fail obj)]))])
+ (if (eq? 'final (vector-ref (class-meth-flags class) pos))
+ (let ([method (vector-ref (class-methods class) pos)])
+ (lambda (obj)
+ (unless (instance? obj) (fail obj))
+ method))
+ dynamic-generic)))))])
+ make-generic))
+
+(define-syntax (send-generic stx)
+ (syntax-case stx ()
+ [(_ object generic . args)
+ (let* ([args-stx (syntax args)]
+ [proper? (stx-list? args-stx)]
+ [flat-stx (if proper? args-stx (flatten-args args-stx))])
+ (with-syntax ([(gen obj)
+ (generate-temporaries (syntax (generic object)))])
+ (class-syntax-protect
+ (quasisyntax/loc stx
+ (let* ([obj object]
+ [gen generic])
+ ;(check-generic gen)
+ (unsyntax
+ (make-method-call-to-possibly-wrapped-object
+ stx #f flat-stx (not proper?)
+ #'(generic-name gen)
+ #'((generic-applicable gen) obj)
+ #'obj
+ #'((generic-applicable gen) obj))))))))]))
+
+(define (check-generic gen)
+ (unless (generic? gen)
+ (raise-argument-error 'send-generic "generic?" gen)))
+
+(define-syntaxes (class-field-accessor class-field-mutator generic/form)
+ (let ([mk
+ (lambda (make targets)
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ class-expr name)
+ (let ([name (syntax name)])
+ (unless (identifier? name)
+ (raise-syntax-error
+ #f
+ "expected an indentifier"
+ stx
+ name))
+ (with-syntax ([name (localize name)]
+ [make make])
+ (class-syntax-protect
+ (syntax/loc stx (make class-expr `name)))))]
+ [(_ class-expr)
+ (raise-syntax-error
+ #f
+ (format "expected a field name after the ~a expression"
+ targets)
+ stx)])))])
+ (values
+ (mk (quote-syntax make-class-field-accessor) "class")
+ (mk (quote-syntax make-class-field-mutator) "class")
+ (mk (quote-syntax make-generic/proc) "class or interface"))))
+
+(define-syntax (set-field! stx)
+ (syntax-case stx ()
+ [(_ name obj val)
+ (identifier? #'name)
+ (with-syntax ([localized (localize #'name)])
+ (class-syntax-protect
+ (syntax/loc stx (set-field!/proc `localized obj val))))]
+ [(_ name obj val)
+ (raise-syntax-error
+ 'set-field! "expected a field name as first argument"
+ stx #'name)]))
+
+(define (set-field!/proc id obj val)
+ (do-set-field! 'set-field! id obj val))
+
+(define (do-set-field! who id obj val)
+ (cond
+ [(_object? obj)
+ (do-set-field!/raw-object who id obj val)]
+ [(wrapped-object? obj)
+ (define projs+set! (hash-ref (wrapped-object-neg-field-projs obj) id #f))
+ (cond
+ [projs+set!
+ (define np (wrapped-object-neg-party obj))
+ (let loop ([projs+set! projs+set!]
+ [val val])
+ (cond
+ [(pair? projs+set!)
+ (define the-proj (car projs+set!))
+ (loop (cdr projs+set!)
+ ((the-proj val) np))]
+ [else
+ (projs+set! (wrapped-object-object obj) val)]))]
+ [else
+ (do-field-get/raw-object who id (wrapped-object-object obj))])]
+ [else
+ (raise-argument-error who
+ "object?"
+ obj)]))
+
+(define (do-set-field!/raw-object who id obj val)
+ (define cls (object-ref obj))
+ (define field-ht (class-field-ht cls))
+ (define fi (hash-ref field-ht id #f))
+ (if fi
+ ((field-info-external-set! fi) obj val)
+ (obj-error who
+ "given object does not have the requested field"
+ "field name" (as-write id)
+ "object" obj)))
+
+(define (dynamic-set-field! id obj val)
+ (unless (symbol? id) (raise-argument-error 'dynamic-set-field! "symbol?" id))
+ (do-set-field! 'dynamic-set-field! id obj val))
+
+(define-syntax (get-field stx)
+ (syntax-case stx ()
+ [(_ name obj)
+ (identifier? (syntax name))
+ (with-syntax ([localized (localize (syntax name))])
+ (class-syntax-protect
+ (syntax/loc stx (get-field/proc `localized obj))))]
+ [(_ name obj)
+ (raise-syntax-error
+ 'get-field "expected a field name as first argument"
+ stx (syntax name))]))
+
+(define (get-field/proc id obj)
+ (do-get-field 'get-field id obj))
+
+(define (do-get-field who id obj)
+ (cond
+ [(_object? obj)
+ (do-field-get/raw-object who id obj)]
+ [(wrapped-object? obj)
+ (define projs+ref (hash-ref (wrapped-object-pos-field-projs obj) id #f))
+ (cond
+ [projs+ref
+ (define np (wrapped-object-neg-party obj))
+ (let loop ([projs+ref projs+ref])
+ (cond
+ [(pair? projs+ref)
+ (define the-proj (car projs+ref))
+ (define field-val-with-other-contracts (loop (cdr projs+ref)))
+ ((the-proj field-val-with-other-contracts) np)]
+ [else
+ ;; projs+ref is the struct field accessor
+ (projs+ref (wrapped-object-object obj))]))]
+ [else
+ (do-field-get/raw-object who id (wrapped-object-object obj))])]
+ [else
+ (raise-argument-error who
+ "object?"
+ obj)]))
+
+(define (do-field-get/raw-object who id obj)
+ (define cls (object-ref obj))
+ (define field-ht (class-field-ht cls))
+ (define fi (hash-ref field-ht id #f))
+ (if fi
+ ((field-info-external-ref fi) obj)
+ (obj-error who
+ "given object does not have the requested field"
+ "field name" (as-write id)
+ "object" obj)))
+
+(define (dynamic-get-field id obj)
+ (unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id))
+ (do-get-field 'dynamic-get-field id obj))
+
+(define-syntax (field-bound? stx)
+ (syntax-case stx ()
+ [(_ name obj)
+ (identifier? (syntax name))
+ (with-syntax ([localized (localize (syntax name))])
+ (class-syntax-protect
+ (syntax (field-bound?/proc `localized obj))))]
+ [(_ name obj)
+ (raise-syntax-error
+ 'field-bound? "expected a field name as first argument"
+ stx (syntax name))]))
+
+(define (field-bound?/proc id obj)
+ (unless (object? obj)
+ (raise-argument-error 'field-bound?
+ "object?"
+ obj))
+ (let loop ([obj obj])
+ (let* ([cls (object-ref/unwrap obj)]
+ [field-ht (class-field-ht cls)])
+ (and (hash-ref field-ht id #f)
+ #t)))) ;; ensure that only #t and #f leak out, not bindings in ht
+
+(define (field-names obj)
+ (unless (object? obj)
+ (raise-argument-error 'field-names
+ "object?"
+ obj))
+ (let loop ([obj obj])
+ (let* ([cls (object-ref/unwrap obj)]
+ [field-ht (class-field-ht cls)]
+ [flds (filter interned? (hash-map field-ht (lambda (x y) x)))])
+ flds)))
+
+(define-syntax (with-method stx)
+ (syntax-case stx ()
+ [(_ ([id (obj-expr name)] ...) body0 body1 ...)
+ (let ([ids (syntax->list (syntax (id ...)))]
+ [names (syntax->list (syntax (name ...)))])
+ (for-each (lambda (id name)
+ (unless (identifier? id)
+ (raise-syntax-error #f
+ "not an identifier for binding"
+ stx
+ id))
+ (unless (identifier? name)
+ (raise-syntax-error #f
+ "not an identifier for method name"
+ stx
+ name)))
+ ids names)
+ (with-syntax ([(method ...) (generate-temporaries ids)]
+ [(method-obj ...) (generate-temporaries ids)]
+ [(name ...) (map localize names)])
+ (class-syntax-protect
+ (syntax/loc stx (let-values ([(method method-obj)
+ (let ([obj obj-expr])
+ (values (find-method/who 'with-method obj `name)
+ obj))]
+ ...)
+ (letrec-syntaxes+values ([(id) (make-with-method-map
+ (quote-syntax set!)
+ (quote-syntax id)
+ (quote-syntax method)
+ (quote-syntax method-obj))]
+ ...)
+ ()
+ body0 body1 ...))))))]
+ ;; Error cases:
+ [(_ (clause ...) . body)
+ (begin
+ (for-each (lambda (clause)
+ (syntax-case clause ()
+ [(id (obj-expr name))
+ (and (identifier? (syntax id))
+ (identifier? (syntax name)))
+ 'ok]
+ [_else
+ (raise-syntax-error
+ #f
+ "binding clause is not of the form (identifier (object-expr method-identifier))"
+ stx
+ clause)]))
+ (syntax->list (syntax (clause ...))))
+ ;; If we get here, the body must be bad
+ (if (stx-null? (syntax body))
+ (raise-syntax-error
+ #f
+ "empty body"
+ stx)
+ (raise-syntax-error
+ #f
+ "bad syntax (illegal use of `.')"
+ stx)))]
+ [(_ x . rest)
+ (raise-syntax-error
+ #f
+ "not a binding sequence"
+ stx
+ (syntax x))]))
+
+
+;;--------------------------------------------------------------------
+;; class, interface, and object properties
+;;--------------------------------------------------------------------
+
+(define (is-a? v c)
+ (cond
+ [(class? c)
+ (and (object? v) ((class-object? (class-orig-cls c)) (unwrap-object v)))]
+ [(interface? c) (and (object? v) (implementation? (object-ref/unwrap v) c))]
+ [else (raise-argument-error 'is-a? "(or/c class? interface?)" 1 v c)]))
+
+(define (subclass? v c)
+ (unless (class? c)
+ (raise-argument-error 'subclass? "class?" 1 v c))
+ (and (class? v)
+ (let* ([c (class-orig-cls c)]
+ [v (class-orig-cls v)]
+ [p (class-pos c)])
+ (and (<= p (class-pos v))
+ (eq? c (vector-ref (class-supers v) p))))))
+
+(define (object-interface o)
+ (unless (object? o)
+ (raise-argument-error 'object-interface "object?" o))
+ (class-self-interface (object-ref/unwrap o)))
+
+(define (object-method-arity-includes? o name cnt)
+ (unless (object? o)
+ (raise-argument-error 'object-method-arity-includes? "object?" o))
+ (unless (symbol? name)
+ (raise-argument-error 'object-method-arity-includes? "symbol?" name))
+ (unless (and (integer? cnt)
+ (exact? cnt)
+ (not (negative? cnt)))
+ (raise-argument-error 'object-method-arity-includes? "exact-nonnegative-integer?" cnt))
+ (define c (object-ref/unwrap o))
+ (define pos (hash-ref (class-method-ht c) name #f))
+ (cond
+ [pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
+ (add1 cnt))]
+ [else #f]))
+
+(define (implementation? v i)
+ (unless (interface? i)
+ (raise-argument-error 'implementation? "interface?" 1 v i))
+ (and (class? v)
+ (interface-extension? (class-self-interface v) i)))
+
+(define (interface-extension? v i)
+ (unless (interface? i)
+ (raise-argument-error 'interface-extension? "interface?" 1 v i))
+ (and (interface? i)
+ (hash-ref (interface-all-implemented v) i #f)))
+
+(define (method-in-interface? s i)
+ (unless (symbol? s)
+ (raise-argument-error 'method-in-interface? "symbol?" 0 s i))
+ (unless (interface? i)
+ (raise-argument-error 'method-in-interface? "interface?" 1 s i))
+ (and (memq s (interface-public-ids i)) #t))
+
+(define (class->interface c)
+ (unless (class? c)
+ (raise-argument-error 'class->interface "class?" c))
+ (class-self-interface c))
+
+(define (interned? sym)
+ (eq? sym (string->symbol (symbol->string sym))))
+
+(define (interface->method-names i)
+ (unless (interface? i)
+ (raise-argument-error 'interface->method-names "interface?" i))
+ (filter interned? (interface-public-ids i)))
+
+
+(define (object-info o)
+ (unless (object? o)
+ (raise-argument-error 'object-info "object?" o))
+ (let ([o* (if (has-original-object? o) (original-object o) o)])
+ (let loop ([c (object-ref/unwrap o*)]
+ [skipped? #f])
+ (if (struct? ((class-insp-mk c)))
+ ;; current objec can inspect this object
+ (values c skipped?)
+ (if (zero? (class-pos c))
+ (values #f #t)
+ (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))
+
+(define (to-sym s)
+ (if (string? s)
+ (string->symbol s)
+ s))
+
+(define (class-info c)
+ (unless (class? c)
+ (raise-argument-error 'class-info "class?" c))
+ (if (struct? ((class-insp-mk c)))
+ (let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
+ (let loop ([next super][skipped? #f])
+ (if (or (not next)
+ (struct? ((class-insp-mk next))))
+ (values (to-sym (class-name c))
+ (- (class-field-width c) (class-field-width super))
+ (filter interned? (class-field-ids c))
+ (class-field-ref c)
+ (class-field-set! c)
+ next
+ skipped?)
+ (if (zero? (class-pos next))
+ (loop #f #t)
+ (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
+ (raise-arguments-error 'class-info "current inspector cannot inspect class"
+ "class" c)))
+
+(define object->vector
+ (lambda (in-o [opaque-v '...])
+ (unless (object? in-o)
+ (raise-argument-error 'object->vector "object?" in-o))
+ (let ([o in-o])
+ (list->vector
+ (cons
+ (string->symbol (format "object:~a" (class-name (object-ref/unwrap o))))
+ (reverse
+ (let-values ([(c skipped?) (object-info o)])
+ (let loop ([c c][skipped? skipped?])
+ (cond
+ [(not c) (if skipped? (list opaque-v) null)]
+ [else (let-values ([(name num-fields field-ids field-ref
+ field-set next next-skipped?)
+ (class-info c)])
+ (let ([rest (loop next next-skipped?)]
+ [here (let loop ([n num-fields])
+ (if (zero? n)
+ null
+ (cons (field-ref o (sub1 n))
+ (loop (sub1 n)))))])
+ (append (if skipped? (list opaque-v) null)
+ here
+ rest)))])))))))))
+
+(define (object=? o1 o2)
+ (cond
+ [(not (object? o1))
+ (raise-argument-error 'object=? "object?" 0 o1 o2)]
+ [(not (object? o2))
+ (raise-argument-error 'object=? "object?" 1 o1 o2)]
+ [else
+ (or (eq? o1 o2) (-object=? o1 o2))]))
+
+(define (object-or-false=? o1 o2)
+ (cond
+ [(and o1 (not (object? o1)))
+ (raise-argument-error 'object-or-false=? "(or/c object? #f)" 0 o1 o2)]
+ [(and o2 (not (object? o2)))
+ (raise-argument-error 'object-or-false=? "(or/c object? #f)" 1 o1 o2)]
+ [else
+ (or (eq? o1 o2)
+ (and o1 o2 (-object=? o1 o2)))]))
+
+(define (-object=? o1 o2)
+ (eq? (object=-original-object o1)
+ (object=-original-object o2)))
+
+(define (object=-original-object o)
+ (define orig-o (if (has-original-object? o) (original-object o) o))
+ (define orig-orig-o
+ (if (wrapped-object? orig-o)
+ (wrapped-object-object orig-o)
+ orig-o))
+ orig-orig-o)
+
+(define (object=-hash-code o)
+ (unless (object? o)
+ (raise-argument-error 'object=-hash-code "object?" 0 o))
+ (eq-hash-code (object=-original-object o)))
+
+;;--------------------------------------------------------------------
+;; primitive classes
+;;--------------------------------------------------------------------
+
+(define (make-primitive-class
+ make-struct:prim ; see below
+ prim-init ; primitive initializer: takes obj and list of name-arg pairs
+ name ; symbol
+ super ; superclass
+ intfs ; interfaces
+ init-arg-names ; #f or list of syms and sym--value lists
+ override-names ; overridden method names
+ new-names ; new (public) method names
+ override-methods ; list of methods
+ new-methods) ; list of methods
+
+ ; The `make-struct:prim' function takes prop:object, a class,
+ ; a preparer, a dispatcher function, an unwrap property,
+ ; an unwrapper, and a property assoc list, and produces:
+ ; * a struct constructor (must have prop:object)
+ ; * a struct predicate
+ ; * a struct type for derived classes (mustn't have prop:object)
+ ;
+ ; The supplied preparer takes a symbol and returns a num.
+ ;
+ ; The supplied dispatcher takes an object and a num and returns a method.
+ ;
+ ; The supplied unwrap property is used for adding the unwrapper
+ ; as a property value on new objects.
+ ;
+ ; The supplied unwrapper takes an object and returns the unwrapped
+ ; version (or the original object).
+ ;
+ ; When a primitive class has a superclass, the struct:prim maker
+ ; is responsible for ensuring that the returned struct items match
+ ; the supertype predicate.
+
+ (compose-class name
+ (or super object%)
+ intfs
+ #f
+ #f
+ #f
+
+ 0 null null null ; no fields
+
+ null ; no rename-supers
+ null ; no rename-inners
+ null null new-names
+ null null override-names
+ null null null ; no augrides
+ null ; no inherits
+
+ ; #f => init args by position only
+ ; sym => required arg
+ ; sym--value list => optional arg
+ (and init-arg-names
+ (map (lambda (s)
+ (if (symbol? s) s (car s)))
+ init-arg-names))
+ 'stop
+
+ (lambda ignored
+ (values
+ new-methods
+ override-methods
+ null ; no augride-methods
+ (lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args)
+ (apply prim-init this
+ (if init-arg-names
+ (extract-primitive-args this name init-arg-names init-args)
+ init-args)))))
+
+ #f
+
+ make-struct:prim))
+
+(define (extract-primitive-args this class-name init-arg-names init-args)
+ (let loop ([names init-arg-names][args init-args])
+ (cond
+ [(null? names)
+ (unless (null? args)
+ (unused-args-error this args))
+ null]
+ [else (let* ([name (car names)]
+ [id (if (symbol? name)
+ name
+ (car name))])
+ (let ([arg (assq id args)])
+ (cond
+ [arg
+ (cons (cdr arg) (loop (cdr names) (remq arg args)))]
+ [(symbol? name)
+ (missing-argument-error class-name name)]
+ [else
+ (cons (cadr name) (loop (cdr names) args))])))])))
+
+;;--------------------------------------------------------------------
+;; wrapper for contracts
+;;--------------------------------------------------------------------
+
+(define-values (impersonator-prop:original-object has-original-object? original-object)
+ (make-impersonator-property 'impersonator-prop:original-object))
+
+
+(define (check-arg-contracts wrapped-blame wrapped-neg-party val init-proj-pairs orig-named-args)
+ ;; blame will be #f only when init-ctc-pairs is '()
+ (define arg-blame (and wrapped-blame (blame-swap wrapped-blame)))
+
+ (define (missing-one init-ctc-pair)
+ (raise-blame-error arg-blame #:missing-party wrapped-neg-party val
+ '(expected: "an init arg named ~a"
+ given:
+ "~a")
+ (car init-ctc-pair)
+ (case (length orig-named-args)
+ [(0) "no init args"]
+ [(1) "an init arg named ~a"
+ (car (car orig-named-args))]
+ [(2) "init args named~a"
+ (apply string-append
+ (map (λ (x) (format " ~a" (car x)))
+ orig-named-args))])))
+ ;; this loop optimizes for the case where the init-ctc-pairs
+ ;; and the named-args are in the same order, making extra
+ ;; passes over the named-args when they aren't.
+ (let loop ([init-proj-pairs init-proj-pairs]
+ [named-args orig-named-args]
+ [named-skipped-args '()]
+ [progress? #f])
+ (cond
+ [(null? init-proj-pairs)
+ (append named-args named-skipped-args)]
+ [(and (null? named-args) (null? named-skipped-args))
+ '()]
+ [(null? named-args)
+ (if progress?
+ (loop init-proj-pairs named-skipped-args '() #f)
+ (loop (cdr init-proj-pairs) named-skipped-args '() #f))]
+ [else
+ (define proj-pair (car init-proj-pairs))
+ (define named-arg (car named-args))
+ (cond
+ [(equal? (list-ref proj-pair 0) (list-ref named-arg 0))
+ (define value-with-contracts-added
+ (for/fold ([val (cdr named-arg)]) ([proj (in-list (cdr proj-pair))])
+ ((proj val) wrapped-neg-party)))
+ (define new-ele (cons (car named-arg) value-with-contracts-added))
+ (cons new-ele
+ (loop (cdr init-proj-pairs) (cdr named-args) named-skipped-args #t))]
+ [else
+ (loop init-proj-pairs
+ (cdr named-args)
+ (cons (car named-args) named-skipped-args)
+ progress?)])])))
+
+
+;;--------------------------------------------------------------------
+;; misc utils
+;;--------------------------------------------------------------------
+
+(define-struct (exn:fail:object exn:fail) () #:inspector insp)
+
+(struct as-write (content))
+(struct as-write-list (content))
+(struct as-value-list (content))
+(struct as-lines (content))
+
+(define (obj-error where
+ msg
+ #:class-name [class-name #f]
+ #:intf-name [intf-name #f]
+ #:which-class [which-class ""]
+ . fields)
+ (define all-fields
+ (append fields
+ (if class-name
+ (list (string-append which-class "class name")
+ (as-write class-name))
+ null)
+ (if intf-name
+ (list "interface name"
+ (as-write intf-name))
+ null)))
+ (raise (make-exn:fail:object
+ (format "~a: ~a~a" where msg
+ (apply
+ string-append
+ (let loop ([fields all-fields])
+ (cond
+ [(null? fields) null]
+ [else
+ (define field (car fields))
+ (define val (cadr fields))
+ (list*
+ "\n "
+ field
+ (if (or (as-write-list? val)
+ (as-lines? val))
+ ":"
+ ": ")
+ (cond
+ [(or (as-write-list? val)
+ (as-value-list? val))
+ (apply string-append
+ (for/list ([v (in-list (if (as-write-list? val)
+ (as-write-list-content val)
+ (as-value-list-content val)))])
+ (format (if (as-write-list? val)
+ "\n ~s"
+ "\n ~e")
+ v)))]
+ [(as-write? val)
+ (format "~s" (as-write-content val))]
+ [(as-lines? val)
+ (as-lines-content val)]
+ [else
+ (format "~e" val)])
+ (loop (cddr fields)))]))))
+ (current-continuation-marks))))
+
+(define (for-class name)
+ (if name (format " for class: ~a" name) ""))
+(define (for-class/which which name)
+ (if name (format " for ~a class: ~a" which name) ""))
+(define (for-intf name)
+ (if name (format " for interface: ~a" name) ""))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; mixin
+;;
+
+(define (check-mixin-super mixin-name super% from-ids)
+ (let ([mixin-name (or mixin-name 'mixin)])
+ (unless (class? super%)
+ (obj-error mixin-name
+ "argument is not a class"
+ "argument" super%))
+ (for-each (lambda (from-id)
+ (unless (implementation? super% from-id)
+ (obj-error mixin-name
+ "argument class does not implement interface"
+ "argument" super%
+ "interface name" (as-write from-id))))
+ from-ids)))
+
+(define (check-mixin-from-interfaces all-from)
+ (for-each (lambda (from-id)
+ (unless (interface? from-id)
+ (obj-error 'mixin
+ "given value for from-interface is not an interface"
+ "given" from-id
+ "all given" (as-value-list all-from))))
+ all-from))
+
+(define (check-mixin-to-interfaces all-to)
+ (for-each (lambda (to-id)
+ (unless (interface? to-id)
+ (obj-error 'mixin
+ "given values for from-interface is not an interface"
+ "given" to-id
+ "all given" (as-value-list all-to))))
+ all-to))
+
+
+(define (check-interface-includes xs from-ids)
+ (for-each
+ (lambda (x)
+ (unless (ormap (lambda (i) (method-in-interface? x i)) from-ids)
+ (obj-error 'mixin
+ "method was referenced in definition, but is not in any of the from-interfaces"
+ "method name" (as-write x)
+ "from-interfaces" (as-write-list from-ids))))
+ xs))
+
+(define-syntax (mixin stx)
+ (syntax-case stx ()
+ [(_ (from ...) (to ...) clauses ...)
+ (let ([extract-renamed-names
+ (λ (x)
+ (map (λ (x)
+ (localize
+ (syntax-case x ()
+ [(internal-name external-name) (syntax external-name)]
+ [else x])))
+ (syntax->list x)))])
+ (define (get-super-names stx)
+ (syntax-case stx (inherit rename
+ override overment override-final
+ define/override define/overment define/override-final
+ augment augride augment-final
+ define/augment define/augride define/augment-final)
+ [(inherit names ...) (extract-renamed-names (syntax (names ...)))]
+ [(rename [x names] ...) (syntax->list (syntax (names ...)))]
+ [(override names ...) (extract-renamed-names (syntax (names ...)))]
+ [(overment names ...) (extract-renamed-names (syntax (names ...)))]
+ [(override-final names ...) (extract-renamed-names (syntax (names ...)))]
+ [(augment names ...) (extract-renamed-names (syntax (names ...)))]
+ [(augride names ...) (extract-renamed-names (syntax (names ...)))]
+ [(augment-final names ...) (extract-renamed-names (syntax (names ...)))]
+
+ [(define/augment (name . names) . rest) (extract-renamed-names (syntax (name)))]
+ [(define/augment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+ [(define/augride (name . names) . rest) (extract-renamed-names (syntax (name)))]
+ [(define/augride name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+ [(define/augment-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
+ [(define/augment-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+ [(define/override (name . names) . rest) (extract-renamed-names (syntax (name)))]
+ [(define/override name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+ [(define/overment (name . names) . rest) (extract-renamed-names (syntax (name)))]
+ [(define/overment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+ [(define/override-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
+ [(define/override-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
+ [else null]))
+ (with-syntax ([(from-ids ...) (generate-temporaries (syntax (from ...)))]
+ [(to-ids ...) (generate-temporaries (syntax (to ...)))]
+ [(super-vars ...)
+ (apply
+ append
+ (map get-super-names
+ (syntax->list (syntax (clauses ...)))))]
+ [mixin-name (or (with-syntax ([tmp (syntax-local-name)])
+ (syntax (quote tmp)))
+ (syntax (quote mixin)))])
+
+ ;; Build the class expression first, to give it a good src location:
+ (with-syntax ([class-expr
+ (with-syntax ([orig-stx stx])
+ (syntax/loc stx
+ (class/derived orig-stx [#f super% (to-ids ...) #f]
+ clauses ...)))])
+
+ ;; Now build mixin proc, again to give it a good src location:
+ (with-syntax ([mixin-expr
+ (syntax/loc stx
+ (λ (super%)
+ (check-mixin-super mixin-name super% (list from-ids ...))
+ class-expr))])
+ ;; Finally, build the complete mixin expression:
+ (class-syntax-protect
+ (syntax/loc stx
+ (let ([from-ids from] ...)
+ (let ([to-ids to] ...)
+ (check-mixin-from-interfaces (list from-ids ...))
+ (check-mixin-to-interfaces (list to-ids ...))
+ (check-interface-includes (list (quasiquote super-vars) ...)
+ (list from-ids ...))
+ mixin-expr))))))))]))
+
+(define externalizable<%>
+ (_interface () externalize internalize))
+
+(define writable<%>
+ (interface* ()
+ ([prop:custom-write (lambda (obj port mode)
+ (if mode
+ (send obj custom-write port)
+ (send obj custom-display port)))])
+ custom-write custom-display))
+
+(define printable<%>
+ (interface* ()
+ ([prop:custom-write (lambda (obj port mode)
+ (case mode
+ [(#t) (send obj custom-write port)]
+ [(#f) (send obj custom-display port)]
+ [else (send obj custom-print port mode)]))])
+ custom-write custom-display custom-print))
+
+(define equal<%>
+ (interface* ()
+ ([prop:equal+hash (list
+ (lambda (obj obj2 base-equal?)
+ (send obj equal-to? obj2 base-equal?))
+ (lambda (obj base-hash-code)
+ (send obj equal-hash-code-of base-hash-code))
+ (lambda (obj base-hash2-code)
+ (send obj equal-secondary-hash-code-of base-hash2-code)))])
+ equal-to? equal-hash-code-of equal-secondary-hash-code-of))
+
+;; Providing normal functionality:
+(provide (protect-out get-field/proc)
+
+ ;; for class-c-old.rkt:
+ (protect-out
+ make-naming-constructor prop:object _object? object-ref replace-ictc-blame
+ concretize-ictc-method field-info-extend-external field-info-extend-internal this-param
+ object-ref/unwrap impersonator-prop:original-object has-original-object? original-object)
+ ;; end class-c-old.rkt requirements
+
+ field-info-internal-ref
+ field-info-internal-set!
+
+ (rename-out [_class class]) class* class/derived
+ define-serializable-class define-serializable-class*
+ class?
+ mixin
+ (rename-out [_interface interface]) interface* interface?
+ object% object? object=? object-or-false=? object=-hash-code
+ externalizable<%> printable<%> writable<%> equal<%>
+ new make-object instantiate
+ get-field set-field! field-bound? field-names
+ dynamic-get-field dynamic-set-field!
+ send send/apply send/keyword-apply send* send+ dynamic-send
+ class-field-accessor class-field-mutator with-method
+ private* public* pubment*
+ override* overment*
+ augride* augment*
+ public-final* override-final* augment-final*
+ define/private define/public define/pubment
+ define/override define/overment
+ define/augride define/augment
+ define/public-final define/override-final define/augment-final
+ define-local-member-name define-member-name
+ member-name-key generate-member-key member-name-key? member-name-key=? member-name-key-hash-code
+ (rename-out [generic/form generic]) (rename-out [make-generic/proc make-generic]) send-generic generic?
+ is-a? subclass? implementation? interface-extension?
+ object-interface object-info object->vector
+ object-method-arity-includes?
+ method-in-interface? interface->method-names class->interface class-info
+ class-seal class-unseal copy-seals
+ (struct-out exn:fail:object)
+ make-primitive-class
+ (for-syntax localize)
+ (except-out (struct-out class) class class?)
+ (rename-out [class? class-struct-predicate?])
+ (struct-out wrapped-object))
diff --git a/test/example/compilation-mode.rkt b/test/example/compilation-mode.rkt
new file mode 100644
index 0000000..fbf077a
--- /dev/null
+++ b/test/example/compilation-mode.rkt
@@ -0,0 +1,12 @@
+#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/example/core.scm b/test/example/core.scm
new file mode 100644
index 0000000..88fcb7f
--- /dev/null
+++ b/test/example/core.scm
@@ -0,0 +1,3098 @@
+;; This program and the accompanying materials are made available under the
+;; terms of the MIT license (X11 license) which accompanies this distribution.
+
+;; Author: C. Bürger
+
+#!r6rs
+
+(library
+ (racr core)
+ (export
+ ;; Specification interface:
+ (rename (make-racr-specification create-specification))
+ ;; Specification query interface:
+ specification->phase
+ specification->start-symbol
+ specification->ast-rules
+ specification->find-ast-rule
+ ast-rule->symbolic-representation
+ ast-rule->supertype?
+ ast-rule->production
+ symbol->name
+ symbol->non-terminal?
+ symbol->kleene?
+ symbol->context-name
+ symbol->attributes
+ attribute->name
+ attribute->circular?
+ attribute->synthesized?
+ attribute->inherited?
+ attribute->cached?
+ ;; ASTs: Specification
+ (rename (specify-ast-rule ast-rule))
+ compile-ast-specifications
+ ;; ASTs: Construction
+ create-ast
+ create-ast-list
+ create-ast-bud
+ create-ast-mockup
+ ;; ASTs: Traversal
+ ast-parent
+ ast-child
+ ast-sibling
+ ast-children
+ ast-for-each-child
+ ast-find-child
+ ast-find-child*
+ ;; ASTs: Node Information
+ ast-node?
+ ast-specification
+ ast-has-parent?
+ ast-child-index
+ ast-has-child?
+ ast-num-children
+ ast-has-sibling?
+ ast-node-type
+ ast-node-rule
+ ast-list-node?
+ ast-bud-node?
+ ast-subtype?
+ ;; Attribution: Specification
+ specify-attribute
+ specify-pattern
+ (rename (specify-ag-rule ag-rule))
+ compile-ag-specifications
+ ;; Attribution: Querying
+ att-value
+ ;; Rewriting: Primitive Rewrite Functions
+ rewrite-terminal
+ rewrite-refine
+ rewrite-abstract
+ rewrite-subtree
+ rewrite-add
+ rewrite-insert
+ rewrite-delete
+ ;; Rewriting: Rewrite Strategies
+ perform-rewrites
+ create-transformer-for-pattern
+ ;; Annotations: Attachment
+ ast-annotation-set!
+ ast-weave-annotations
+ ast-annotation-remove!
+ ;; Annotations: Querying
+ ast-annotation?
+ ast-annotation
+ ;; Support
+ with-specification
+ with-bindings
+ ;; Utility interface:
+ racr-exception?
+ make-atom)
+ (import (rnrs) (rnrs mutable-pairs))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Internal Data Structures ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define-record-type atom ; Unique key entities, each instance is only equal to itself.
+ (nongenerative atom:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (sealed #t)(opaque #t)(fields (mutable dummy-value))
+ (protocol
+ (lambda (new)
+ (lambda ()
+ (new #t)))))
+
+ (define racr-nil (make-atom)) ; Unique value indicating undefined RACR entities
+
+ ;; Record type representing RACR compiler specifications. A compiler specification consists of arbitrary
+ ;; many AST rule, attribute and rewrite specifications, all aggregated into a set of rules stored in a
+ ;; non-terminal-symbol -> ast-rule hashtable, an actual compiler specification phase and a distinguished
+ ;; start symbol. The specification phase is an internal flag indicating the RACR system the compiler's
+ ;; specification progress. Possible phases are:
+ ;; 1 : AST specification
+ ;; 2 : AG specification
+ ;; 3 : Rewrite specification
+ ;; 4 : Specification finished
+ (define-record-type racr-specification
+ (nongenerative racr-specification:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields (mutable specification-phase) rules-table (mutable start-symbol))
+ (opaque #t)(sealed #t)
+ (protocol
+ (lambda (new)
+ (lambda ()
+ (new 1 (make-eq-hashtable 50) racr-nil)))))
+
+ ;; INTERNAL FUNCTION: Given a RACR specification and a non-terminal, return the
+ ;; non-terminal's AST rule or #f if it is undefined.
+ (define racr-specification-find-rule
+ (lambda (spec non-terminal)
+ (hashtable-ref (racr-specification-rules-table spec) non-terminal #f)))
+
+ ;; INTERNAL FUNCTION: Given a RACR specification return a list of its AST rules.
+ (define racr-specification-rules-list
+ (lambda (spec)
+ (call-with-values
+ (lambda ()
+ (hashtable-entries (racr-specification-rules-table spec)))
+ (lambda (key-vector value-vector)
+ (vector->list value-vector)))))
+
+ ;; Record type for AST rules;; An AST rule has a reference to the RACR specification it belongs to and consist
+ ;; of its symbolic encoding, a production (i.e., a list of production-symbols) and an optional supertype.
+ (define-record-type ast-rule
+ (nongenerative ast-rule:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields specification as-symbol (mutable production) (mutable supertype?))
+ (opaque #t)(sealed #t))
+
+ ;; INTERNAL FUNCTION: Given an AST rule find a certain child context by name. If the rule defines no such
+ ;; context, return #f, otherwise the production symbol defining the respective context.
+ (define ast-rule-find-child-context
+ (lambda (r context-name)
+ (find
+ (lambda (symbol)
+ (eq? (symbol-context-name symbol) context-name))
+ (cdr (ast-rule-production r)))))
+
+ ;; INTERNAL FUNCTION: Given two rules r1 and r2, return whether r1 is a subtype of r2 or not. The subtype
+ ;; relationship is reflexive, i.e., every type is a subtype of itself.
+ ;; BEWARE: Only works correct if supertypes are resolved, otherwise an exception can be thrown!
+ (define ast-rule-subtype?
+ (lambda (r1 r2)
+ (and
+ (eq? (ast-rule-specification r1) (ast-rule-specification r2))
+ (let loop ((r1 r1))
+ (cond
+ ((eq? r1 r2) #t)
+ ((ast-rule-supertype? r1) (loop (ast-rule-supertype? r1)))
+ (else #f))))))
+
+ ;; INTERNAL FUNCTION: Given a rule, return a list containing all its subtypes except the rule itself.
+ ;; BEWARE: Only works correct if supertypes are resolved, otherwise an exception can be thrown!
+ (define ast-rule-subtypes
+ (lambda (rule1)
+ (filter
+ (lambda (rule2)
+ (and (not (eq? rule2 rule1)) (ast-rule-subtype? rule2 rule1)))
+ (racr-specification-rules-list (ast-rule-specification rule1)))))
+
+ ;; Record type for production symbols; A production symbol is part of a certain ast rule and has name,
+ ;; a flag indicating whether it is a non-terminal or not (later resolved to the actual AST rule representing
+ ;; the respective non-terminal), a flag indicating whether it represents a Kleene closure (i.e., is a list
+ ;; of certain type) or not, a context-name unambiguously referencing it within the production it is part of
+ ;; and a list of attributes defined for it.
+ (define-record-type (symbol make-production-symbol production-symbol?)
+ (nongenerative symbol:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields name ast-rule (mutable non-terminal?) kleene? context-name (mutable attributes))
+ (opaque #t)(sealed #t))
+
+ ;; Record type for attribute definitions. An attribute definition has a certain name, a definition context
+ ;; (i.e., a symbol of an AST rule), an equation and an optional circularity-definition used for fix-point
+ ;; computations. Further, attribute definitions specify whether the value of instances of the defined
+ ;; attribute are cached. Circularity-definitions are (bottom-value equivalence-function) pairs, whereby
+ ;; bottom-value is the value fix-point computations start with and equivalence-functions are used to decide
+ ;; whether a fix-point is reached or not (i.e., equivalence-functions are arbitrary functions of arity two
+ ;; computing whether two given arguments are equal or not).
+ (define-record-type attribute-definition
+ (nongenerative attribute-definition:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields name context equation circularity-definition cached?)
+ (opaque #t)(sealed #t))
+
+ ;; INTERNAL FUNCTION: Given an attribute definition, check if instances can depend on
+ ;; themself (i.e., be circular) or not.
+ (define attribute-definition-circular?
+ (lambda (att)
+ (if (attribute-definition-circularity-definition att) #t #f)))
+
+ ;; INTERNAL FUNCTION: Given an attribute definition, return whether it specifies
+ ;; a synthesized attribute or not.
+ (define attribute-definition-synthesized?
+ (lambda (att-def)
+ (let ((symbol (attribute-definition-context att-def)))
+ (eq? (car (ast-rule-production (symbol-ast-rule symbol))) symbol))))
+
+ ;; INTERNAL FUNCTION: Given an attribute definition, return whether it specifies
+ ;; an inherited attribute or not.
+ (define attribute-definition-inherited?
+ (lambda (att-def)
+ (not (attribute-definition-synthesized? att-def))))
+
+ ;; Record type for AST nodes. AST nodes have a reference to the evaluator state used for evaluating their
+ ;; attributes and rewrites, the AST rule they represent a context of, their parent, children, attribute
+ ;; instances, attribute cache entries they influence and annotations.
+ (define-record-type node
+ (nongenerative node:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields
+ (mutable evaluator-state)
+ (mutable ast-rule)
+ (mutable parent)
+ (mutable children)
+ (mutable attributes)
+ (mutable cache-influences)
+ (mutable annotations))
+ (opaque #t)(sealed #t)
+ (protocol
+ (lambda (new)
+ (lambda (ast-rule parent children)
+ (new
+ #f
+ ast-rule
+ parent
+ children
+ (list)
+ (list)
+ (list))))))
+
+ ;; INTERNAL FUNCTION: Given a node, return whether it is a terminal or not.
+ (define node-terminal?
+ (lambda (n)
+ (eq? (node-ast-rule n) 'terminal)))
+
+ ;; INTERNAL FUNCTION: Given a node, return whether it is a non-terminal or not.
+ (define node-non-terminal?
+ (lambda (n)
+ (not (node-terminal? n))))
+
+ ;; INTERNAL FUNCTION: Given a node, return whether it is a list node or not.
+ (define node-list-node?
+ (lambda (n)
+ (eq? (node-ast-rule n) 'list-node)))
+
+ ;; INTERNAL FUNCTION: Given a node, return whether it is a bud node or not.
+ (define node-bud-node?
+ (lambda (n)
+ (eq? (node-ast-rule n) 'bud-node)))
+
+ ;; INTERNAL FUNCTION: Given a node, return its child-index if it has a parent, otherwise return #f.
+ (define node-child-index?
+ (lambda (n)
+ (if (node-parent n)
+ (let loop ((children (node-children (node-parent n)))
+ (pos 1))
+ (if (eq? (car children) n)
+ pos
+ (loop (cdr children) (+ pos 1))))
+ #f)))
+
+ ;; INTERNAL FUNCTION: Given a node find a certain child by name. If the node has
+ ;; no such child, return #f, otherwise the child.
+ (define node-find-child
+ (lambda (n context-name)
+ (and (not (node-list-node? n))
+ (not (node-bud-node? n))
+ (not (node-terminal? n))
+ (let loop ((contexts (cdr (ast-rule-production (node-ast-rule n))))
+ (children (node-children n)))
+ (if (null? contexts)
+ #f
+ (if (eq? (symbol-context-name (car contexts)) context-name)
+ (car children)
+ (loop (cdr contexts) (cdr children))))))))
+
+ ;; INTERNAL FUNCTION: Given a node find a certain attribute associated with it. If the node
+ ;; has no such attribute, return #f, otherwise the attribute.
+ (define node-find-attribute
+ (lambda (n name)
+ (find
+ (lambda (att)
+ (eq? (attribute-definition-name (attribute-instance-definition att)) name))
+ (node-attributes n))))
+
+ ;; INTERNAL FUNCTION: Given two nodes n1 and n2, return whether n1 is within the subtree spaned by n2 or not.
+ (define node-inside-of?
+ (lambda (n1 n2)
+ (cond
+ ((eq? n1 n2) #t)
+ ((node-parent n1) (node-inside-of? (node-parent n1) n2))
+ (else #f))))
+
+ ;; Record type for attribute instances of a certain attribute definition, associated with
+ ;; a certain node (context) and a cache.
+ (define-record-type attribute-instance
+ (nongenerative attribute-instance:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields (mutable definition) (mutable context) cache)
+ (opaque #t)(sealed #t)
+ (protocol
+ (lambda (new)
+ (lambda (definition context)
+ (new definition context (make-hashtable equal-hash equal? 1))))))
+
+ ;; Record type for attribute cache entries. Attribute cache entries represent the values of
+ ;; and dependencies between attribute instances evaluated for certain arguments. The attribute
+ ;; instance of which an entry represents a value is called its context. If an entry already
+ ;; is evaluated, it caches the result of its context evaluated for its arguments. If an entry is
+ ;; not evaluated but its context is circular it stores an intermediate result of its fixpoint
+ ;; computation, called cycle value. Entries also track whether they are already in evaluation or
+ ;; not, such that the attribute evaluator can detect unexpected cycles.
+ (define-record-type attribute-cache-entry
+ (nongenerative attribute-cache-entry:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields
+ (mutable context)
+ (mutable arguments)
+ (mutable value)
+ (mutable cycle-value)
+ (mutable entered?)
+ (mutable node-dependencies)
+ (mutable cache-dependencies)
+ (mutable cache-influences))
+ (opaque #t)(sealed #t)
+ (protocol
+ (lambda (new)
+ (lambda (att arguments) ; att: The attribute instance for which to construct a cache entry
+ (new
+ att
+ arguments
+ racr-nil
+ (let ((circular? (attribute-definition-circularity-definition (attribute-instance-definition att))))
+ (if circular?
+ (car circular?)
+ racr-nil))
+ #f
+ (list)
+ (list)
+ (list))))))
+
+ ;; Record type representing the internal state of RACR systems throughout their execution, i.e., while
+ ;; evaluating attributes and rewriting ASTs. An evaluator state consists of a flag indicating if the AG
+ ;; currently performs a fix-point evaluation, a flag indicating if throughout a fix-point iteration the
+ ;; value of an attribute changed and an attribute evaluation stack used for dependency tracking.
+ (define-record-type evaluator-state
+ (nongenerative evaluator-state:4eac95849d0fb73142c398c35979fa20a71b9d02)
+ (fields (mutable ag-in-cycle?) (mutable ag-cycle-change?) (mutable evaluation-stack))
+ (opaque #t)(sealed #t)
+ (protocol
+ (lambda (new)
+ (lambda ()
+ (new #f #f (list))))))
+
+ ;; INTERNAL FUNCTION: Given an evaluator state, return whether it represents an evaluation in progress or
+ ;; not; If it represents an evaluation in progress return the current attribute in evaluation, otherwise #f.
+ (define evaluator-state-in-evaluation?
+ (lambda (state)
+ (and (not (null? (evaluator-state-evaluation-stack state))) (car (evaluator-state-evaluation-stack state)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Support API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; INTERNAL FUNCTION: Given an arbitrary Scheme entity, construct a string
+ ;; representation of it using display.
+ (define object->string
+ (lambda (x)
+ (call-with-string-output-port
+ (lambda (port)
+ (display x port)))))
+
+ (define-condition-type racr-exception &violation make-racr-exception racr-exception?)
+
+ ;; INTERNAL FUNCTION: Given an arbitrary sequence of strings and other Scheme entities, concatenate them to
+ ;; form an error message and throw a special RACR exception with the constructed message. Any entity that is
+ ;; not a string is treated as error information embedded in the error message between [ and ] characters,
+ ;; whereby the actual string representation of the entity is obtained using object->string.
+ (define-syntax throw-exception
+ (syntax-rules ()
+ ((_ m-part ...)
+ (raise-continuable
+ (condition
+ (make-racr-exception)
+ (make-message-condition
+ (string-append
+ "RACR exception: "
+ (let ((m-part* m-part))
+ (if (string? m-part*)
+ m-part*
+ (string-append "[" (object->string m-part*) "]"))) ...)))))))
+
+ ;; INTERNAL FUNCTION: Procedure sequentially applying a function on all the AST rules of a set of rules which
+ ;; inherit, whereby supertypes are processed before their subtypes.
+ (define apply-wrt-ast-inheritance
+ (lambda (func rules)
+ (let loop ((resolved ; The set of all AST rules that are already processed....
+ (filter ; ...Initially it consists of all the rules that have no supertypes.
+ (lambda (rule)
+ (not (ast-rule-supertype? rule)))
+ rules))
+ (to-check ; The set of all AST rules that still must be processed....
+ (filter ; ...Initially it consists of all the rules that have supertypes.
+ (lambda (rule)
+ (ast-rule-supertype? rule))
+ rules)))
+ (let ((to-resolve ; ...Find a rule that still must be processed and...
+ (find
+ (lambda (rule)
+ (memq (ast-rule-supertype? rule) resolved)) ; ...whose supertype already has been processed....
+ to-check)))
+ (when to-resolve ; ...If such a rule exists,...
+ (func to-resolve) ; ...process it and...
+ (loop (cons to-resolve resolved) (remq to-resolve to-check))))))) ; ...recur.
+
+ (define-syntax with-specification
+ (lambda (x)
+ (syntax-case x ()
+ ((k spec body ...)
+ #`(let* ((spec* spec)
+ (#,(datum->syntax #'k 'ast-rule)
+ (lambda (rule)
+ (specify-ast-rule spec* rule)))
+ (#,(datum->syntax #'k 'compile-ast-specifications)
+ (lambda (start-symbol)
+ (compile-ast-specifications spec* start-symbol)))
+ (#,(datum->syntax #'k 'compile-ag-specifications)
+ (lambda ()
+ (compile-ag-specifications spec*)))
+ (#,(datum->syntax #'k 'create-ast)
+ (lambda (rule children)
+ (create-ast spec* rule children)))
+ (#,(datum->syntax #'k 'specification->phase)
+ (lambda ()
+ (specification->phase spec*)))
+ (#,(datum->syntax #'k 'specify-attribute)
+ (lambda (att-name non-terminal index cached? equation circ-def)
+ (specify-attribute spec* att-name non-terminal index cached? equation circ-def)))
+ (#,(datum->syntax #'k 'specify-pattern)
+ (lambda (att-name distinguished-node fragments references condition)
+ (specify-pattern spec* att-name distinguished-node fragments references condition)))
+ (#,(datum->syntax #'k 'create-transformer-for-pattern)
+ (lambda (node-type pattern-attribute rewrite-function . pattern-arguments)
+ (apply create-transformer-for-pattern spec* node-type pattern-attribute rewrite-function pattern-arguments))))
+ (let-syntax ((#,(datum->syntax #'k 'ag-rule)
+ (syntax-rules ()
+ ((_ attribute-name definition (... ...))
+ (specify-ag-rule spec* attribute-name definition (... ...))))))
+ body ...))))))
+
+ (define-syntax with-bindings
+ (syntax-rules ()
+ ((_ ((binding ...) (parameter ...)) body body* ...)
+ (lambda (l parameter ...)
+ (let ((binding (cdr (assq 'binding l))) ...)
+ body
+ body* ...)))
+ ((_ (binding ...) body body* ...)
+ (with-bindings ((binding ...) ()) body body* ...))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Abstract Syntax Tree Annotations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define ast-weave-annotations
+ (lambda (node type name value)
+ (when (evaluator-state-in-evaluation? (node-evaluator-state node))
+ (throw-exception
+ "Cannot weave " name " annotation; "
+ "There are attributes in evaluation."))
+ (when (not (ast-annotation? node name))
+ (cond
+ ((and (not (ast-list-node? node)) (not (ast-bud-node? node)) (ast-subtype? node type))
+ (ast-annotation-set! node name value))
+ ((and (ast-list-node? node) (eq? type 'list-node))
+ (ast-annotation-set! node name value))
+ ((and (ast-bud-node? node) (eq? type 'bud-node))
+ (ast-annotation-set! node name value))))
+ (for-each
+ (lambda (child)
+ (unless (node-terminal? child)
+ (ast-weave-annotations child type name value)))
+ (node-children node))))
+
+ (define ast-annotation?
+ (lambda (node name)
+ (when (evaluator-state-in-evaluation? (node-evaluator-state node))
+ (throw-exception
+ "Cannot check for " name " annotation; "
+ "There are attributes in evaluation."))
+ (assq name (node-annotations node))))
+
+ (define ast-annotation
+ (lambda (node name)
+ (when (evaluator-state-in-evaluation? (node-evaluator-state node))
+ (throw-exception
+ "Cannot access " name " annotation; "
+ "There are attributes in evaluation."))
+ (let ((annotation (ast-annotation? node name)))
+ (if annotation
+ (cdr annotation)
+ (throw-exception
+ "Cannot access " name " annotation; "
+ "The given node has no such annotation.")))))
+
+ (define ast-annotation-set!
+ (lambda (node name value)
+ (when (evaluator-state-in-evaluation? (node-evaluator-state node))
+ (throw-exception
+ "Cannot set " name " annotation; "
+ "There are attributes in evaluation."))
+ (when (not (symbol? name))
+ (throw-exception
+ "Cannot set " name " annotation; "
+ "Annotation names must be Scheme symbols."))
+ (let ((annotation (ast-annotation? node name))
+ (value
+ (if (procedure? value)
+ (lambda args
+ (apply value node args))
+ value)))
+ (if annotation
+ (set-cdr! annotation value)
+ (node-annotations-set! node (cons (cons name value) (node-annotations node)))))))
+
+ (define ast-annotation-remove!
+ (lambda (node name)
+ (when (evaluator-state-in-evaluation? (node-evaluator-state node))
+ (throw-exception
+ "Cannot remove " name " annotation; "
+ "There are attributes in evaluation."))
+ (node-annotations-set!
+ node
+ (remp
+ (lambda (entry)
+ (eq? (car entry) name))
+ (node-annotations node)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Abstract Syntax Tree Specification ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define specify-ast-rule
+ (lambda (spec rule)
+ ;;; Ensure, that the RACR system is in the correct specification phase:
+ (when (> (racr-specification-specification-phase spec) 1)
+ (throw-exception
+ "Unexpected AST rule " rule "; "
+ "AST rules can only be defined in the AST specification phase."))
+ (letrec* ((ast-rule ; The parsed AST rule that will be added to the given specification.
+ (make-ast-rule
+ spec
+ rule
+ racr-nil
+ racr-nil))
+ (rule-string (symbol->string rule)) ; String representation of the encoded rule (used for parsing)
+ (pos 0) ; The current parsing position
+ ;; Support function returning, whether the end of the parsing string is reached or not:
+ (eos?
+ (lambda ()
+ (= pos (string-length rule-string))))
+ ;; Support function returning the current character to parse:
+ (my-peek-char
+ (lambda ()
+ (string-ref rule-string pos)))
+ ;; Support function returning the current character to parse and incrementing the parsing position:
+ (my-read-char
+ (lambda ()
+ (let ((c (my-peek-char)))
+ (set! pos (+ pos 1))
+ c)))
+ ;; Support function matching a certain character:
+ (match-char!
+ (lambda (c)
+ (if (eos?)
+ (throw-exception
+ "Unexpected end of AST rule " rule ";"
+ "Expected " c " character.")
+ (if (char=? (my-peek-char) c)
+ (set! pos (+ pos 1))
+ (throw-exception
+ "Invalid AST rule " rule "; "
+ "Unexpected " (my-peek-char) " character.")))))
+ ;; Support function parsing a symbol, i.e., retrieving its name, type, if it is a list and optional context name.
+ (parse-symbol
+ (lambda (location) ; location: l-hand, r-hand
+ (let ((symbol-type (if (eq? location 'l-hand) "non-terminal" "terminal")))
+ (when (eos?)
+ (throw-exception
+ "Unexpected end of AST rule " rule "; "
+ "Expected " symbol-type "."))
+ (let* ((parse-name
+ (lambda (terminal?)
+ (let* ((character-part
+ (let loop ((chars (list)))
+ (if (and (not (eos?)) (char-alphabetic? (my-peek-char)))
+ (begin
+ (when (and terminal? (not (char-lower-case? (my-peek-char))))
+ (throw-exception
+ "Invalid AST rule " rule "; "
+ "Unexpected " (my-peek-char) " character."))
+ (loop (cons (my-read-char) chars)))
+ (reverse chars))))
+ (numerical-part
+ (let loop ((chars (list)))
+ (if (and (not (eos?)) (char-numeric? (my-peek-char)))
+ (loop (cons (my-read-char) chars))
+ (reverse chars))))
+ (name (append character-part numerical-part)))
+ (when (null? name)
+ (throw-exception
+ "Unexpected " (my-peek-char) " character in AST rule " rule "; "
+ "Expected " symbol-type "."))
+ (unless (char-alphabetic? (car name))
+ (throw-exception
+ "Malformed name in AST rule " rule "; "
+ "Names must start with a letter."))
+ name)))
+ (terminal? (char-lower-case? (my-peek-char)))
+ (name (parse-name terminal?))
+ (kleene?
+ (and
+ (not terminal?)
+ (eq? location 'r-hand)
+ (not (eos?))
+ (char=? (my-peek-char) #\*)
+ (my-read-char)))
+ (context-name?
+ (and
+ (not terminal?)
+ (eq? location 'r-hand)
+ (not (eos?))
+ (char=? (my-peek-char) #\<)
+ (my-read-char)
+ (parse-name #f)))
+ (name-string (list->string name))
+ (name-symbol (string->symbol name-string)))
+ (when (and terminal? (eq? location 'l-hand))
+ (throw-exception
+ "Unexpected " name " terminal in AST rule " rule "; "
+ "Left hand side symbols must be non-terminals."))
+ (make-production-symbol
+ name-symbol
+ ast-rule
+ (not terminal?)
+ kleene?
+ (if context-name?
+ (string->symbol (list->string context-name?))
+ (if kleene?
+ (string->symbol (string-append name-string "*"))
+ name-symbol))
+ (list))))))
+ (l-hand (parse-symbol 'l-hand)); The rule's l-hand
+ (supertype ; The rule's super-type
+ (and (not (eos?)) (char=? (my-peek-char) #\:) (my-read-char) (symbol-name (parse-symbol 'l-hand)))))
+ (match-char! #\-)
+ (match-char! #\>)
+ (ast-rule-production-set!
+ ast-rule
+ (append
+ (list l-hand)
+ (let loop ((r-hand
+ (if (not (eos?))
+ (list (parse-symbol 'r-hand))
+ (list))))
+ (if (eos?)
+ (reverse r-hand)
+ (begin
+ (match-char! #\-)
+ (loop (cons (parse-symbol 'r-hand) r-hand)))))))
+ (ast-rule-supertype?-set!
+ ast-rule
+ supertype)
+ ;; Check, that the rule's l-hand is not already defined:
+ (when (racr-specification-find-rule spec (symbol-name l-hand))
+ (throw-exception
+ "Invalid AST rule " rule "; "
+ "Redefinition of " (symbol-name l-hand) "."))
+ (hashtable-set! ; Add the rule to the RACR specification.
+ (racr-specification-rules-table spec)
+ (symbol-name l-hand)
+ ast-rule))))
+
+ (define compile-ast-specifications
+ (lambda (spec start-symbol)
+ ;;; Ensure, that the RACR system is in the correct specification phase and...
+ (let ((current-phase (racr-specification-specification-phase spec)))
+ (if (> current-phase 1)
+ (throw-exception
+ "Unexpected AST compilation; "
+ "The AST specifications already have been compiled.")
+ ;; ...iff so proceed to the next specification phase:
+ (racr-specification-specification-phase-set! spec (+ current-phase 1))))
+
+ (racr-specification-start-symbol-set! spec start-symbol)
+ (let* ((rules-list (racr-specification-rules-list spec))
+ ;; Support function, that given a rule R returns a list of all rules directly derivable from R:
+ (derivable-rules
+ (lambda (rule*)
+ (fold-left
+ (lambda (result symb*)
+ (if (symbol-non-terminal? symb*)
+ (append result (list (symbol-non-terminal? symb*)) (ast-rule-subtypes (symbol-non-terminal? symb*)))
+ result))
+ (list)
+ (cdr (ast-rule-production rule*))))))
+
+ ;;; Resolve supertypes and non-terminals occuring in productions and ensure all non-terminals are defined:
+ (for-each
+ (lambda (rule*)
+ (when (ast-rule-supertype? rule*)
+ (let ((supertype-entry (racr-specification-find-rule spec (ast-rule-supertype? rule*))))
+ (if (not supertype-entry)
+ (throw-exception
+ "Invalid AST rule " (ast-rule-as-symbol rule*) "; "
+ "The supertype " (ast-rule-supertype? rule*) " is not defined.")
+ (ast-rule-supertype?-set! rule* supertype-entry))))
+ (for-each
+ (lambda (symb*)
+ (when (symbol-non-terminal? symb*)
+ (let ((symb-definition (racr-specification-find-rule spec (symbol-name symb*))))
+ (when (not symb-definition)
+ (throw-exception
+ "Invalid AST rule " (ast-rule-as-symbol rule*) "; "
+ "Non-terminal " (symbol-name symb*) " is not defined."))
+ (symbol-non-terminal?-set! symb* symb-definition))))
+ (cdr (ast-rule-production rule*))))
+ rules-list)
+
+ ;;; Ensure, that inheritance is cycle-free:
+ (for-each
+ (lambda (rule*)
+ (when (memq rule* (ast-rule-subtypes rule*))
+ (throw-exception
+ "Invalid AST grammar; "
+ "The definition of " (ast-rule-as-symbol rule*) " depends on itself (cyclic inheritance).")))
+ rules-list)
+
+ ;;; Ensure, that the start symbol is defined:
+ (unless (racr-specification-find-rule spec start-symbol)
+ (throw-exception
+ "Invalid AST grammar; "
+ "The start symbol " start-symbol " is not defined."))
+
+ ;;; Resolve inherited production symbols:
+ (apply-wrt-ast-inheritance
+ (lambda (rule)
+ (ast-rule-production-set!
+ rule
+ (append
+ (list (car (ast-rule-production rule)))
+ (map
+ (lambda (symbol)
+ (make-production-symbol
+ (symbol-name symbol)
+ rule
+ (symbol-non-terminal? symbol)
+ (symbol-kleene? symbol)
+ (symbol-context-name symbol)
+ (list)))
+ (cdr (ast-rule-production (ast-rule-supertype? rule))))
+ (cdr (ast-rule-production rule)))))
+ rules-list)
+
+ ;;; Ensure context-names are unique:
+ (for-each
+ (lambda (ast-rule)
+ (for-each
+ (lambda (symbol)
+ (unless (eq? (ast-rule-find-child-context ast-rule (symbol-context-name symbol)) symbol)
+ (throw-exception
+ "Invalid AST grammar; "
+ "The context name " (symbol-context-name symbol) " is not unique for rule " (ast-rule-as-symbol ast-rule) ".")))
+ (cdr (ast-rule-production ast-rule))))
+ rules-list)
+
+ ;;; Ensure, that all non-terminals can be derived from the start symbol:
+ (let* ((start-rule (racr-specification-find-rule spec start-symbol))
+ (to-check (cons start-rule (ast-rule-subtypes start-rule)))
+ (checked (list)))
+ (let loop ()
+ (unless (null? to-check)
+ (let ((rule* (car to-check)))
+ (set! to-check (cdr to-check))
+ (set! checked (cons rule* checked))
+ (for-each
+ (lambda (derivable-rule)
+ (when (and
+ (not (memq derivable-rule checked))
+ (not (memq derivable-rule to-check)))
+ (set! to-check (cons derivable-rule to-check))))
+ (derivable-rules rule*))
+ (loop))))
+ (let ((non-derivable-rules
+ (filter
+ (lambda (rule*)
+ (not (memq rule* checked)))
+ rules-list)))
+ (unless (null? non-derivable-rules)
+ (throw-exception
+ "Invalid AST grammar; "
+ "The rules " (map ast-rule-as-symbol non-derivable-rules) " cannot be derived."))))
+
+ ;;; Ensure, that all non-terminals are productive:
+ (let* ((productive-rules (list))
+ (to-check rules-list)
+ (productive-rule?
+ (lambda (rule*)
+ (not (find
+ (lambda (symb*)
+ (and
+ (symbol-non-terminal? symb*)
+ (not (symbol-kleene? symb*)) ; Unbounded repetitions are always productive because of the empty list.
+ (not (memq (symbol-non-terminal? symb*) productive-rules))))
+ (cdr (ast-rule-production rule*)))))))
+ (let loop ()
+ (let ((productive-rule
+ (find productive-rule? to-check)))
+ (when productive-rule
+ (set! to-check (remq productive-rule to-check))
+ (set! productive-rules (cons productive-rule productive-rules))
+ (loop))))
+ (unless (null? to-check)
+ (throw-exception
+ "Invalid AST grammar; "
+ "The rules " (map ast-rule-as-symbol to-check) " are not productive."))))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Attribute Specification ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define-syntax specify-ag-rule
+ (lambda (x)
+ (syntax-case x ()
+ ((_ spec att-name definition ...)
+ (and (identifier? #'att-name) (not (null? #'(definition ...))))
+ #'(let ((spec* spec)
+ (att-name* 'att-name))
+ (let-syntax
+ ((specify-attribute*
+ (syntax-rules ()
+ ((_ spec* att-name* ((non-terminal index) equation))
+ (specify-attribute spec* att-name* 'non-terminal 'index #t equation #f))
+ ((_ spec* att-name* ((non-terminal index) cached? equation))
+ (specify-attribute spec* att-name* 'non-terminal 'index cached? equation #f))
+ ((_ spec* att-name* ((non-terminal index) equation bottom equivalence-function))
+ (specify-attribute spec* att-name* 'non-terminal 'index #t equation (cons bottom equivalence-function)))
+ ((_ spec* att-name* ((non-terminal index) cached? equation bottom equivalence-function))
+ (specify-attribute spec* att-name* 'non-terminal 'index cached? equation (cons bottom equivalence-function)))
+ ((_ spec* att-name* (non-terminal equation))
+ (specify-attribute spec* att-name* 'non-terminal 0 #t equation #f))
+ ((_ spec* att-name* (non-terminal cached? equation))
+ (specify-attribute spec* att-name* 'non-terminal 0 cached? equation #f))
+ ((_ spec* att-name* (non-terminal equation bottom equivalence-function))
+ (specify-attribute spec* att-name* 'non-terminal 0 #t equation (cons bottom equivalence-function)))
+ ((_ spec* att-name* (non-terminal cached? equation bottom equivalence-function))
+ (specify-attribute spec* att-name* 'non-terminal 0 cached? equation (cons bottom equivalence-function))))))
+ (specify-attribute* spec* att-name* definition) ...))))))
+
+ (define specify-attribute
+ (lambda (spec attribute-name non-terminal context-name-or-position cached? equation circularity-definition)
+ ;;; Before adding the attribute definition, ensure...
+ (let ((wrong-argument-type ; ...correct argument types,...
+ (or
+ (and (not (symbol? attribute-name))
+ "Attribute name : symbol")
+ (and (not (symbol? non-terminal))
+ "AST rule : non-terminal")
+ (and (not (symbol? context-name-or-position))
+ (or (not (integer? context-name-or-position)) (< context-name-or-position 0))
+ "Production position : index or context-name")
+ (and (not (procedure? equation))
+ "Attribute equation : function")
+ (and circularity-definition
+ (not (pair? circularity-definition))
+ (not (procedure? (cdr circularity-definition)))
+ "Circularity definition : #f or (bottom-value equivalence-function) pair"))))
+ (when wrong-argument-type
+ (throw-exception
+ "Invalid attribute definition; "
+ "Wrong argument type (" wrong-argument-type ").")))
+ (unless (= (racr-specification-specification-phase spec) 2) ; ...that the RACR system is in the correct specification phase,...
+ (throw-exception
+ "Unexpected " attribute-name " attribute definition; "
+ "Attributes can only be defined in the AG specification phase."))
+ (let ((ast-rule (racr-specification-find-rule spec non-terminal)))
+ (unless ast-rule ; ...the given AST rule is defined,...
+ (throw-exception
+ "Invalid attribute definition; "
+ "The non-terminal " non-terminal " is not defined."))
+ (let* ((context? ; ...the given context exists,...
+ (if (symbol? context-name-or-position)
+ (if (eq? context-name-or-position '*)
+ (car (ast-rule-production ast-rule))
+ (ast-rule-find-child-context ast-rule context-name-or-position))
+ (if (>= context-name-or-position (length (ast-rule-production ast-rule)))
+ (throw-exception
+ "Invalid attribute definition; "
+ "There exists no " context-name-or-position "'th position in the context of " non-terminal ".")
+ (list-ref (ast-rule-production ast-rule) context-name-or-position)))))
+ (unless context?
+ (throw-exception
+ "Invalid attribute definition; "
+ "The non-terminal " non-terminal " has no " context-name-or-position " context."))
+ (unless (symbol-non-terminal? context?) ; ...it is a non-terminal and...
+ (throw-exception
+ "Invalid attribute definition; "
+ non-terminal context-name-or-position " is a terminal."))
+ ; ...the attribute is not already defined for it:
+ (when (memq attribute-name (map attribute-definition-name (symbol-attributes context?)))
+ (throw-exception
+ "Invalid attribute definition; "
+ "Redefinition of " attribute-name " for " non-terminal context-name-or-position "."))
+ ;;; Everything is fine. Thus, add the definition to the AST rule's respective symbol:
+ (symbol-attributes-set!
+ context?
+ (cons
+ (make-attribute-definition
+ attribute-name
+ context?
+ equation
+ circularity-definition
+ cached?)
+ (symbol-attributes context?)))))))
+
+ (define compile-ag-specifications
+ (lambda (spec)
+ ;;; Ensure, that the RACR system is in the correct specification phase and...
+ (let ((current-phase (racr-specification-specification-phase spec)))
+ (when (< current-phase 2)
+ (throw-exception
+ "Unexpected AG compilation; "
+ "The AST specifications are not yet compiled."))
+ (if (> current-phase 2)
+ (throw-exception
+ "Unexpected AG compilation; "
+ "The AG specifications already have been compiled.")
+ (racr-specification-specification-phase-set! spec (+ current-phase 1)))) ; ...if so proceed to the next specification phase.
+
+ ;;; Resolve attribute definitions inherited from a supertype. Thus,...
+ (apply-wrt-ast-inheritance ; ...for every AST rule R which has a supertype...
+ (lambda (rule)
+ (let loop ((super-prod (ast-rule-production (ast-rule-supertype? rule)))
+ (sub-prod (ast-rule-production rule)))
+ (unless (null? super-prod)
+ (for-each ; ...check for every attribute definition of R's supertype...
+ (lambda (super-att-def)
+ (unless (find ; ...if it is shadowed by an attribute definition of R....
+ (lambda (sub-att-def)
+ (eq? (attribute-definition-name sub-att-def) (attribute-definition-name super-att-def)))
+ (symbol-attributes (car sub-prod)))
+ (symbol-attributes-set! ; ...If not, add...
+ (car sub-prod)
+ (cons
+ (make-attribute-definition ; ...a copy of the attribute definition inherited...
+ (attribute-definition-name super-att-def)
+ (car sub-prod) ; ...to R.
+ (attribute-definition-equation super-att-def)
+ (attribute-definition-circularity-definition super-att-def)
+ (attribute-definition-cached? super-att-def))
+ (symbol-attributes (car sub-prod))))))
+ (symbol-attributes (car super-prod)))
+ (loop (cdr super-prod) (cdr sub-prod)))))
+ (racr-specification-rules-list spec))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Attribute Evaluation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; INTERNAL FUNCTION: Given a node n find a certain attribute associated with it, whereas in case no proper
+ ;; attribute is associated with n itself the search is extended to find a broadcast solution. If the
+ ;; extended search finds a solution, appropriate copy propergation attributes (i.e., broadcasters) are added.
+ ;; If no attribute instance can be found or n is a bud node, an exception is thrown. Otherwise, the
+ ;; attribute or its respective last broadcaster is returned.
+ (define lookup-attribute
+ (lambda (name n)
+ (when (node-bud-node? n)
+ (throw-exception
+ "AG evaluator exception; "
+ "Cannot access " name " attribute - the given node is a bud."))
+ (let loop ((n n)) ; Recursively...
+ (let ((att (node-find-attribute n name))) ; ...check if the current node has a proper attribute instance....
+ (if att
+ att ; ...If it has, return the found defining attribute instance.
+ (let ((parent (node-parent n))) ; ...If no defining attribute instance can be found...
+ (if (not parent) ; ...check if there exists a parent node that may provide a definition....
+ (throw-exception ; ...If not, throw an exception,...
+ "AG evaluator exception; "
+ "Cannot access unknown " name " attribute.")
+ (let* ((att (loop parent)) ; ...otherwise proceed the search at the parent node. If it succeeds...
+ (broadcaster ; ...construct a broadcasting attribute instance...
+ (make-attribute-instance
+ (make-attribute-definition ; ...whose definition context depends...
+ name
+ (if (eq? (node-ast-rule parent) 'list-node) ; ...if the parent node is a list node or not....
+ (list-ref ; ...If it is a list node the broadcaster's context is...
+ (ast-rule-production (node-ast-rule (node-parent parent))) ; ...the list node's parent node and...
+ (node-child-index? parent)) ; ...child position.
+ (list-ref ; ...If the parent node is not a list node the broadcaster's context is...
+ (ast-rule-production (node-ast-rule parent)) ; ...the parent node and...
+ (node-child-index? n))) ; ...the current node's child position. Further,...
+ (lambda (n . args) ; ...the broadcaster's equation just calls the parent node's counterpart. Finally,...
+ (apply att-value name (ast-parent n) args))
+ (attribute-definition-circularity-definition (attribute-instance-definition att))
+ #f)
+ n)))
+ (node-attributes-set! n (cons broadcaster (node-attributes n))) ; ...add the constructed broadcaster and...
+ broadcaster)))))))) ; ...return it as the current node's look-up result.
+
+ (define att-value
+ (lambda (name n . args)
+ (let*-values (; The evaluator state used and changed throughout evaluation:
+ ((evaluator-state) (values (node-evaluator-state n)))
+ ;; The attribute instance to evaluate:
+ ((att) (values (lookup-attribute name n)))
+ ;; The attribute's definition:
+ ((att-def) (values (attribute-instance-definition att)))
+ ;; The attribute cache entries used for evaluation and dependency tracking:
+ ((evaluation-att-cache dependency-att-cache)
+ (if (attribute-definition-cached? att-def)
+ ;; If the attribute instance is cached, no special action is required, except...
+ (let ((att-cache
+ (or
+ ;; ...finding the attribute cache entry to use...
+ (hashtable-ref (attribute-instance-cache att) args #f)
+ ;; ...or construct a respective one.
+ (let ((new-entry (make-attribute-cache-entry att args)))
+ (hashtable-set! (attribute-instance-cache att) args new-entry)
+ new-entry))))
+ (values att-cache att-cache))
+ ;; If the attribute is not cached, special attention must be paid to avoid the permament storing
+ ;; of fixpoint results and attribute arguments on the one hand but still retaining correct
+ ;; evaluation which requires these information on the other hand. To do so we introduce two
+ ;; different types of attribute cache entries:
+ ;; (1) A parameter approximating entry for tracking dependencies and influences of the uncached
+ ;; attribute instance.
+ ;; (2) A set of temporary cycle entries for correct cycle detection and fixpoint computation.
+ ;; The "cycle-value" field of the parameter approximating entry is misused to store the hashtable
+ ;; containing the temporary cycle entries and must be deleted when evaluation finished.
+ (let* ((dependency-att-cache
+ (or
+ (hashtable-ref (attribute-instance-cache att) racr-nil #f)
+ (let ((new-entry (make-attribute-cache-entry att racr-nil)))
+ (hashtable-set! (attribute-instance-cache att) racr-nil new-entry)
+ (attribute-cache-entry-cycle-value-set!
+ new-entry
+ (make-hashtable equal-hash equal? 1))
+ new-entry)))
+ (evaluation-att-cache
+ (or
+ (hashtable-ref (attribute-cache-entry-cycle-value dependency-att-cache) args #f)
+ (let ((new-entry (make-attribute-cache-entry att args)))
+ (hashtable-set!
+ (attribute-cache-entry-cycle-value dependency-att-cache)
+ args
+ new-entry)
+ new-entry))))
+ (values evaluation-att-cache dependency-att-cache))))
+ ;; Support function that given an intermediate fixpoint result checks if it is different from the
+ ;; current cycle value and updates the cycle value and evaluator state accordingly:
+ ((update-cycle-cache)
+ (values
+ (lambda (new-result)
+ (unless ((cdr (attribute-definition-circularity-definition att-def))
+ new-result
+ (attribute-cache-entry-cycle-value evaluation-att-cache))
+ (attribute-cache-entry-cycle-value-set! evaluation-att-cache new-result)
+ (evaluator-state-ag-cycle-change?-set! evaluator-state #t))))))
+ ;; Decide how to evaluate the attribute dependening on whether its value already is cached or its respective
+ ;; cache entry is circular, already in evaluation or starting point of a fix-point computation:
+ (cond
+ ;; CASE (0): Attribute already evaluated for given arguments:
+ ((not (eq? (attribute-cache-entry-value evaluation-att-cache) racr-nil))
+ ;; Maintaine attribute cache entry dependencies, i.e., if this entry is evaluated throughout the
+ ;; evaluation of another entry, the other entry depends on this one. Afterwards,...
+ (add-dependency:cache->cache dependency-att-cache)
+ (attribute-cache-entry-value evaluation-att-cache)) ; ...return the cached value.
+
+ ;; CASE (1): Circular attribute that is starting point of a fixpoint computation:
+ ((and (attribute-definition-circular? att-def) (not (evaluator-state-ag-in-cycle? evaluator-state)))
+ (dynamic-wind
+ (lambda ()
+ ;; Maintaine attribute cache entry dependencies, i.e., if this entry is evaluated throughout the
+ ;; evaluation of another entry, the other depends on this one. Further this entry depends
+ ;; on any other entry that will be evaluated through its own evaluation. Further,..
+ (add-dependency:cache->cache dependency-att-cache)
+ (evaluator-state-evaluation-stack-set!
+ evaluator-state
+ (cons dependency-att-cache (evaluator-state-evaluation-stack evaluator-state)))
+ ;; ...mark, that the entry is in evaluation and...
+ (attribute-cache-entry-entered?-set! evaluation-att-cache #t)
+ ;; ...update the evaluator's state that we are about to start a fix-point computation.
+ (evaluator-state-ag-in-cycle?-set! evaluator-state #t))
+ (lambda ()
+ (let loop () ; Start fix-point computation. Thus, as long as...
+ (evaluator-state-ag-cycle-change?-set! evaluator-state #f) ; ...an entry's value changes...
+ (update-cycle-cache (apply (attribute-definition-equation att-def) n args)) ; ...evaluate this entry.
+ (when (evaluator-state-ag-cycle-change? evaluator-state)
+ (loop)))
+ (let ((result (attribute-cache-entry-cycle-value evaluation-att-cache)))
+ ;; When fixpoint computation finished update the caches of all circular entries evaluated. To do so,...
+ (let loop ((att-cache
+ (if (attribute-definition-cached? att-def)
+ evaluation-att-cache
+ dependency-att-cache)))
+ (let ((att-def (attribute-instance-definition (attribute-cache-entry-context att-cache))))
+ (if (not (attribute-definition-circular? att-def))
+ ;; ...ignore non-circular entries and just proceed with the entries they depend on (to
+ ;; ensure all strongly connected components within a weakly connected one are updated)....
+ (for-each
+ loop
+ (attribute-cache-entry-cache-dependencies att-cache))
+ ;; ...In case of circular entries...
+ (if (attribute-definition-cached? att-def) ; ...check if they have to be cached and...
+ (when (eq? (attribute-cache-entry-value att-cache) racr-nil) ; ...are not already processed....
+ ;; ...If so cache them,...
+ (attribute-cache-entry-value-set!
+ att-cache
+ (attribute-cache-entry-cycle-value att-cache))
+ (attribute-cache-entry-cycle-value-set! ; ...reset their cycle values to the bottom value and...
+ att-cache
+ (car (attribute-definition-circularity-definition att-def)))
+ (for-each ; ...proceed with the entries they depend on.
+ loop
+ (attribute-cache-entry-cache-dependencies att-cache)))
+ ;; ...If a circular entry is not cached, check if it already is processed....
+ (when (> (hashtable-size (attribute-cache-entry-cycle-value att-cache)) 0)
+ ; ...If not, delete its temporary cycle cache and...
+ (hashtable-clear! (attribute-cache-entry-cycle-value att-cache))
+ (for-each ; ...proceed with the entries it depends on.
+ loop
+ (attribute-cache-entry-cache-dependencies att-cache)))))))
+ result))
+ (lambda ()
+ ;; Mark that fixpoint computation finished,...
+ (evaluator-state-ag-in-cycle?-set! evaluator-state #f)
+ ;; the evaluation of the attribute cache entry finished and...
+ (attribute-cache-entry-entered?-set! evaluation-att-cache #f)
+ ;; ...pop the entry from the evaluation stack.
+ (evaluator-state-evaluation-stack-set!
+ evaluator-state
+ (cdr (evaluator-state-evaluation-stack evaluator-state))))))
+
+ ;; CASE (2): Circular attribute already in evaluation for the given arguments:
+ ((and (attribute-definition-circular? att-def) (attribute-cache-entry-entered? evaluation-att-cache))
+ ;; Maintaine attribute cache entry dependencies, i.e., if this entry is evaluated throughout the
+ ;; evaluation of another entry, the other entry depends on this one. Finally,...
+ (add-dependency:cache->cache dependency-att-cache)
+ ;; ...the intermediate fixpoint result is the attribute cache entry's cycle value.
+ (attribute-cache-entry-cycle-value evaluation-att-cache))
+
+ ;; CASE (3): Circular attribute not in evaluation and entered throughout a fixpoint computation:
+ ((attribute-definition-circular? att-def)
+ (dynamic-wind
+ (lambda ()
+ ;; Maintaine attribute cache entry dependencies, i.e., if this entry is evaluated throughout the
+ ;; evaluation of another entry, the other depends on this one. Further this entry depends
+ ;; on any other entry that will be evaluated through its own evaluation. Further,..
+ (add-dependency:cache->cache dependency-att-cache)
+ (evaluator-state-evaluation-stack-set!
+ evaluator-state
+ (cons dependency-att-cache (evaluator-state-evaluation-stack evaluator-state)))
+ ;; ...mark, that the entry is in evaluation.
+ (attribute-cache-entry-entered?-set! evaluation-att-cache #t))
+ (lambda ()
+ (let ((result (apply (attribute-definition-equation att-def) n args))) ; Evaluate the entry and...
+ (update-cycle-cache result) ; ...update its cycle value.
+ result))
+ (lambda ()
+ ;; Mark that the evaluation of the attribute cache entry finished and...
+ (attribute-cache-entry-entered?-set! evaluation-att-cache #f)
+ ;; ...pop it from the evaluation stack.
+ (evaluator-state-evaluation-stack-set!
+ evaluator-state
+ (cdr (evaluator-state-evaluation-stack evaluator-state))))))
+
+ ;; CASE (4): Non-circular attribute already in evaluation, i.e., unexpected cycle:
+ ((attribute-cache-entry-entered? evaluation-att-cache)
+ ;; Maintaine attribute cache entry dependencies, i.e., if this entry is evaluated throughout the
+ ;; evaluation of another entry, the other entry depends on this one. Then,...
+ (add-dependency:cache->cache dependency-att-cache)
+ (throw-exception ; ...thrown an exception because we encountered an unexpected dependency cycle.
+ "AG evaluator exception; "
+ "Unexpected " name " cycle."))
+
+ (else ; CASE (5): Non-circular attribute not in evaluation:
+ (dynamic-wind
+ (lambda ()
+ ;; Maintaine attribute cache entry dependencies, i.e., if this entry is evaluated throughout the
+ ;; evaluation of another entry, the other depends on this one. Further this entry depends
+ ;; on any other entry that will be evaluated through its own evaluation. Further,...
+ (add-dependency:cache->cache dependency-att-cache)
+ (evaluator-state-evaluation-stack-set!
+ evaluator-state
+ (cons dependency-att-cache (evaluator-state-evaluation-stack evaluator-state)))
+ ;; ...mark, that the entry is in evaluation.
+ (attribute-cache-entry-entered?-set! evaluation-att-cache #t))
+ (lambda ()
+ (let ((result (apply (attribute-definition-equation att-def) n args))) ; Evaluate the entry and,...
+ (when (attribute-definition-cached? att-def) ; ...if caching is enabled,...
+ (attribute-cache-entry-value-set! evaluation-att-cache result)) ; ...cache its value.
+ result))
+ (lambda ()
+ ;; Mark that the evaluation of the attribute cache entry finished and...
+ (if (attribute-definition-cached? att-def)
+ (attribute-cache-entry-entered?-set! evaluation-att-cache #f)
+ (hashtable-delete! (attribute-cache-entry-cycle-value dependency-att-cache) args))
+ ;; ...pop it from the evaluation stack.
+ (evaluator-state-evaluation-stack-set!
+ evaluator-state
+ (cdr (evaluator-state-evaluation-stack evaluator-state))))))))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Specification Queries ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; General Note: Because RACR specifications never change after compilation, there is no need to add and
+ ;; maintain dependencies when attributes query specifications. The specification query API therefore just
+ ;; forwards to the respective internal functions. Lists must be copied before they are returned however.
+
+ ;; Specification Queries:
+
+ (define specification->phase
+ (lambda (spec)
+ (racr-specification-specification-phase spec)))
+
+ (define specification->start-symbol
+ (lambda (spec)
+ (racr-specification-start-symbol spec)))
+
+ (define specification->ast-rules
+ (lambda (spec)
+ (racr-specification-rules-list spec))) ; Already creates copy!
+
+ (define specification->find-ast-rule
+ (lambda (spec node-type)
+ (racr-specification-find-rule spec node-type)))
+
+ ;; AST Rule Queries:
+
+ (define ast-rule->symbolic-representation
+ (lambda (ast-rule)
+ (ast-rule-as-symbol ast-rule)))
+
+ (define ast-rule->supertype?
+ (lambda (ast-rule)
+ (ast-rule-supertype? ast-rule)))
+
+ (define ast-rule->production
+ (lambda (rule)
+ (append (ast-rule-production rule) (list)))) ; Create copy!
+
+ ;; Production Symbol Queries:
+
+ (define symbol->name
+ (lambda (symb)
+ (symbol-name symb)))
+
+ (define symbol->non-terminal?
+ (lambda (symb)
+ (symbol-non-terminal? symb)))
+
+ (define symbol->kleene?
+ (lambda (symb)
+ (symbol-kleene? symb)))
+
+ (define symbol->context-name
+ (lambda (symb)
+ (symbol-context-name symb)))
+
+ (define symbol->attributes
+ (lambda (symbol)
+ (append (symbol-attributes symbol) (list)))) ; Create copy!
+
+ ;; Attribute Definition Queries:
+
+ (define attribute->name
+ (lambda (att-def)
+ (attribute-definition-name att-def)))
+
+ (define attribute->circular?
+ (lambda (att-def)
+ (attribute-definition-circular? att-def)))
+
+ (define attribute->synthesized?
+ (lambda (att-def)
+ (attribute-definition-synthesized? att-def)))
+
+ (define attribute->inherited?
+ (lambda (att-def)
+ (attribute-definition-inherited? att-def)))
+
+ (define attribute->cached?
+ (lambda (att-def)
+ (attribute-definition-cached? att-def)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Abstract Syntax Tree Queries ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define ast-node? ; Scheme entities are either allocated as AST nodes or never will be => No need to add dependencies!
+ (lambda (n)
+ (node? n)))
+
+ (define ast-specification
+ (lambda (n)
+ (when (or (ast-list-node? n) (ast-bud-node? n)) ; Remember: Terminal nodes as such are never exposed to users.
+ (throw-exception
+ "Cannot query specification; "
+ "List and bud nodes are not part of any specification."))
+ ;; The specification of a node can never change => No need to add dependencies!
+ (ast-rule-specification (node-ast-rule n))))
+
+ (define ast-list-node? ; No dependency tracking needed!
+ (lambda (n)
+ (node-list-node? n)))
+
+ (define ast-bud-node? ; No dependency tracking needed!
+ (lambda (n)
+ (node-bud-node? n)))
+
+ (define ast-node-rule
+ (lambda (n)
+ (when (or (ast-list-node? n) (ast-bud-node? n)) ; Remember: Terminal nodes as such are never exposed to users.
+ (throw-exception
+ "Cannot query type; "
+ "List and bud nodes have no type."))
+ (add-dependency:cache->node-type n)
+ (node-ast-rule n)))
+
+ (define ast-node-type
+ (lambda (n)
+ (symbol-name (car (ast-rule-production (ast-node-rule n))))))
+
+ (define ast-subtype?
+ (lambda (a1 a2)
+ (when (or
+ (and (ast-node? a1) (or (ast-list-node? a1) (ast-bud-node? a1)))
+ (and (ast-node? a2) (or (ast-list-node? a2) (ast-bud-node? a2))))
+ (throw-exception
+ "Cannot perform subtype check; "
+ "List and bud nodes cannot be tested for subtyping."))
+ (when (and (not (ast-node? a1)) (not (ast-node? a2)))
+ (throw-exception
+ "Cannot perform subtype check; "
+ "At least one argument must be an AST node."))
+ ((lambda (t1/t2)
+ (and
+ (car t1/t2)
+ (cdr t1/t2)
+ (ast-rule-subtype? (car t1/t2) (cdr t1/t2))))
+ (if (symbol? a1)
+ (let* ((t2 (node-ast-rule a2))
+ (t1 (racr-specification-find-rule (ast-rule-specification t2) a1)))
+ (unless t1
+ (throw-exception
+ "Cannot perform subtype check; "
+ a1 " is no valid non-terminal (first argument undefined non-terminal)."))
+ (add-dependency:cache->node-super-type a2 t1)
+ (cons t1 t2))
+ (if (symbol? a2)
+ (let* ((t1 (node-ast-rule a1))
+ (t2 (racr-specification-find-rule (ast-rule-specification t1) a2)))
+ (unless t1
+ (throw-exception
+ "Cannot perform subtype check; "
+ a2 " is no valid non-terminal (second argument undefined non-terminal)."))
+ (add-dependency:cache->node-sub-type a1 t2)
+ (cons t1 t2))
+ (begin
+ (add-dependency:cache->node-sub-type a1 (node-ast-rule a2))
+ (add-dependency:cache->node-super-type a2 (node-ast-rule a1))
+ (cons (node-ast-rule a1) (node-ast-rule a2))))))))
+
+ (define ast-has-parent?
+ (lambda (n)
+ (let ((parent (node-parent n)))
+ (if parent
+ (begin
+ (add-dependency:cache->node-upwards parent)
+ parent)
+ (begin
+ (add-dependency:cache->node-is-root n)
+ #f)))))
+
+ (define ast-parent
+ (lambda (n)
+ (let ((parent (node-parent n)))
+ (unless parent
+ (throw-exception "Cannot query parent of roots."))
+ (add-dependency:cache->node-upwards parent)
+ parent)))
+
+ (define ast-has-child?
+ (lambda (context-name n)
+ (add-dependency:cache->node-defines-context n context-name)
+ (if (node-find-child n context-name) #t #f))) ; BEWARE: Never return the child if it exists, but instead just #t!
+
+ (define ast-child
+ (lambda (i n)
+ (let ((child
+ (if (symbol? i)
+ (node-find-child n i)
+ (and (>= i 1) (<= i (length (node-children n))) (list-ref (node-children n) (- i 1))))))
+ (unless child
+ (throw-exception "Cannot query non-existent " i (if (symbol? i) "" "'th") " child."))
+ (add-dependency:cache->node-downwards child)
+ (if (node-terminal? child)
+ (node-children child)
+ child))))
+
+ (define ast-has-sibling?
+ (lambda (context-name n)
+ (let ((parent? (ast-has-parent? n)))
+ (and parent? (ast-has-child? context-name parent?)))))
+
+ (define ast-sibling
+ (lambda (i n)
+ (ast-child i (ast-parent n))))
+
+ (define ast-child-index
+ (lambda (n)
+ (ast-find-child*
+ (lambda (i child)
+ (if (eq? child n) i #f))
+ (ast-parent n))))
+
+ (define ast-num-children
+ (lambda (n)
+ (add-dependency:cache->node-num-children n)
+ (length (node-children n))))
+
+ (define ast-children
+ (lambda (n . b)
+ (reverse
+ (let ((result (list)))
+ (apply
+ ast-for-each-child
+ (lambda (i child)
+ (set! result (cons child result)))
+ n
+ b)
+ result))))
+
+ (define ast-for-each-child
+ (lambda (f n . b)
+ (let ((b (if (null? b) (list (cons 1 '*)) b)))
+ (for-each
+ (lambda (b)
+ (if (eq? (cdr b) '*)
+ (let ((pos (car b))
+ (ub (length (node-children n))))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (let loop ()
+ (when (<= pos ub)
+ (f pos (ast-child pos n))
+ (set! pos (+ pos 1))
+ (loop))))
+ (lambda ()
+ (when (> pos ub)
+ (ast-num-children n))))) ; BEWARE: Access to number of children ensures proper dependency tracking!
+ (let loop ((pos (car b)))
+ (when (<= pos (cdr b))
+ (f pos (ast-child pos n))
+ (loop (+ pos 1))))))
+ b))))
+
+ (define ast-find-child
+ (lambda (f n . b)
+ (call/cc
+ (lambda (c)
+ (apply
+ ast-for-each-child
+ (lambda (i child)
+ (when (f i child)
+ (c child)))
+ n
+ b)
+ #f))))
+
+ (define ast-find-child*
+ (lambda (f n . b)
+ (call/cc
+ (lambda (c)
+ (apply
+ ast-for-each-child
+ (lambda (i child)
+ (let ((res (f i child)))
+ (when res
+ (c res))))
+ n
+ b)
+ #f))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Abstract Syntax Tree Construction ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define create-ast
+ (lambda (spec rule children)
+ ;;; Before constructing the node ensure, that...
+ (when (< (racr-specification-specification-phase spec) 3) ; ...the RACR system is completely specified,...
+ (throw-exception
+ "Cannot construct " rule " fragment; "
+ "The RACR specification still must be compiled."))
+ (let* ((ast-rule (racr-specification-find-rule spec rule))
+ (new-fragment
+ (make-node
+ ast-rule
+ #f
+ (list))))
+ (unless ast-rule ; ...the given AST rule is defined,...
+ (throw-exception
+ "Cannot construct " rule " fragment; "
+ "Unknown non-terminal/rule."))
+ (unless (satisfies-contexts? children (cdr (ast-rule-production ast-rule))) ; ...and the children fit.
+ (throw-exception
+ "Cannot construct " rule " fragment; "
+ "The given children do not fit."))
+ ;;; When all constraints are satisfied, construct the new fragment,...
+ (node-children-set! ; ...add its children,...
+ new-fragment
+ (map ; ...set it as parent of each child,...
+ (lambda (symbol child)
+ (if (symbol-non-terminal? symbol)
+ (begin
+ (for-each ; ...flush all attribute cache entries depending on any added child being a root,...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 1))
+ (node-cache-influences child)))
+ (node-parent-set! child new-fragment)
+ child)
+ (make-node 'terminal new-fragment child)))
+ (cdr (ast-rule-production ast-rule))
+ children))
+ (distribute-evaluator-state (make-evaluator-state) new-fragment) ; ...distribute the new fragment's evaluator state and...
+ (update-synthesized-attribution new-fragment) ; ...initialize its synthesized and...
+ (for-each ; ...each child's inherited attributes.
+ update-inherited-attribution
+ (node-children new-fragment))
+ new-fragment))) ; Finally, return the newly constructed fragment.
+
+ (define create-ast-list
+ (lambda (children)
+ ;;; Before constructing the list node ensure, that...
+ (let ((new-list
+ (make-node
+ 'list-node
+ #f
+ (append children (list))))) ; BEWARE: create copy of children!
+ (unless
+ (for-all ; ...all children fit.
+ (lambda (child)
+ (valid-list-element-candidate? new-list child))
+ children)
+ (throw-exception
+ "Cannot construct list node; "
+ "The given children do not fit."))
+ ;;; When all constraints are satisfied,...
+ (for-each ; ...flush all attribute cache entries depending on the children being roots,...
+ (lambda (child)
+ (for-each
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 1))
+ (node-cache-influences child))))
+ children)
+ (for-each ; ...set the new list node as parent of every child,...
+ (lambda (child)
+ (node-parent-set! child new-list))
+ children)
+ (distribute-evaluator-state (make-evaluator-state) new-list) ; ...construct and distribute its evaluator state and...
+ new-list))) ; ...return it.
+
+ (define create-ast-bud
+ (lambda ()
+ (let ((bud-node (make-node 'bud-node #f (list))))
+ (distribute-evaluator-state (make-evaluator-state) bud-node)
+ bud-node)))
+
+ (define create-ast-mockup
+ (lambda (rule)
+ (create-ast
+ (ast-rule-specification rule)
+ (symbol-name (car (ast-rule-production rule)))
+ (map
+ (lambda (symbol)
+ (cond
+ ((not (symbol-non-terminal? symbol))
+ racr-nil)
+ ((symbol-kleene? symbol)
+ (create-ast-list (list)))
+ (else (create-ast-bud))))
+ (cdr (ast-rule-production rule))))))
+
+ ;; INTERNAL FUNCTION: Given two non-terminal nodes, return if the second can replace the first regarding its context.
+ (define valid-replacement-candidate?
+ (lambda (node candidate)
+ (if (node-list-node? (node-parent node))
+ (valid-list-element-candidate? (node-parent node) candidate)
+ (and
+ (satisfies-context?
+ candidate
+ (list-ref (ast-rule-production (node-ast-rule (node-parent node))) (node-child-index? node)))
+ (not (node-inside-of? node candidate))))))
+
+ ;; INTERNAL FUNCTION: Given a list node and another node, return if the other node can become element of
+ ;; the list node regarding its context.
+ (define valid-list-element-candidate?
+ (lambda (list-node candidate)
+ (let ((expected-type? ; If the list node has a parent, its parent induces a type for the list's elements.
+ (if (node-parent list-node)
+ (symbol-non-terminal?
+ (list-ref
+ (ast-rule-production (node-ast-rule (node-parent list-node)))
+ (node-child-index? list-node)))
+ #f)))
+ (and ; The given candidate can be element of the list, if (1)...
+ (if expected-type? ; ...either,...
+ (satisfies-context? candidate expected-type? #f) ; ...the candidate fits regarding the context in which the list is, or,...
+ (and ; ...in case no type is induced for the list's elements,...
+ (ast-node? candidate) ; ...the candiate is a non-terminal node,...
+ (not (node-list-node? candidate)) ; ...not a list node,...
+ (not (node-parent candidate)) ; ...not already part of another AST and...
+ (not (evaluator-state-in-evaluation? (node-evaluator-state candidate))))) ; ...non of its attributes are in evaluation,...
+ (not (node-inside-of? list-node candidate)))))) ; ...and (2) its spaned AST does not contain the list node.
+
+ ;; INTERNAL FUNCTION: Given a node or terminal value and a context, return if the
+ ;; node/terminal value can become a child of the given context.
+ (define satisfies-context?
+ (case-lambda
+ ((child context)
+ (satisfies-context? child (symbol-non-terminal? context) (symbol-kleene? context)))
+ ((child non-terminal? kleene?)
+ (or ; The given child is valid if either,...
+ (not non-terminal?) ; ...a terminal is expected or,...
+ (and ; ...in case a non-terminal is expected,...
+ (ast-node? child) ; ...the given child is an AST node,...
+ (not (node-parent child)) ; ...does not already belong to another AST,...
+ (not (evaluator-state-in-evaluation? (node-evaluator-state child))) ; ...non of its attributes are in evaluation and...
+ (or
+ (node-bud-node? child) ; ...the child either is a bud node or,...
+ (if kleene?
+ (and ; ...in case a list node is expected,...
+ (node-list-node? child) ; ...is a list...
+ (for-all ; ...whose children are...
+ (lambda (child)
+ (or ; ...either bud nodes or nodes of the expected type, or,...
+ (node-bud-node? child)
+ (ast-rule-subtype? (node-ast-rule child) non-terminal?)))
+ (node-children child)))
+ (and ; ...in case a non-list node is expected,...
+ (not (node-list-node? child)) ; ...is a non-list node of...
+ (ast-rule-subtype? (node-ast-rule child) non-terminal?))))))))) ; ...the expected type.
+
+ ;; INTERNAL FUNCTION: Given list of nodes or terminal values and a list of contexts, return if the
+ ;; nodes/terminal values can become children of the given contexts.
+ (define satisfies-contexts?
+ (lambda (children contexts)
+ (and
+ (= (length children) (length contexts))
+ (for-all satisfies-context? children contexts))))
+
+ ;; INTERNAL FUNCTION: Given an AST node update its synthesized attribution (i.e., add missing synthesized
+ ;; attributes, delete superfluous ones, shadow equally named inherited attributes and update the
+ ;; definitions of existing synthesized attributes.
+ (define update-synthesized-attribution
+ (lambda (n)
+ (when (and (not (node-terminal? n)) (not (node-list-node? n)) (not (node-bud-node? n)))
+ (for-each
+ (lambda (att-def)
+ (let ((att (node-find-attribute n (attribute-definition-name att-def))))
+ (cond
+ ((not att)
+ (node-attributes-set! n (cons (make-attribute-instance att-def n) (node-attributes n))))
+ ((eq? (attribute-definition-equation (attribute-instance-definition att)) (attribute-definition-equation att-def))
+ (attribute-instance-definition-set! att att-def))
+ (else
+ (flush-attribute-instance att)
+ (node-attributes-set!
+ n
+ (cons (make-attribute-instance att-def n) (remq att (node-attributes n))))))))
+ (symbol-attributes (car (ast-rule-production (node-ast-rule n)))))
+ (node-attributes-set! ; Delete all synthesized attribute instances not defined anymore:
+ n
+ (remp
+ (lambda (att)
+ (let ((remove?
+ (and
+ (attribute-definition-synthesized? (attribute-instance-definition att))
+ (not
+ (eq?
+ (symbol-ast-rule (attribute-definition-context (attribute-instance-definition att)))
+ (node-ast-rule n))))))
+ (when remove?
+ (flush-attribute-instance att))
+ remove?))
+ (node-attributes n))))))
+
+ ;; INTERNAL FUNCTION: Given an AST node update its inherited attribution (i.e., add missing inherited
+ ;; attributes, delete superfluous ones and update the definitions of existing inherited attributes.
+ ;; If the given node is a list-node the inherited attributes of its elements are updated.
+ (define update-inherited-attribution
+ (lambda (n)
+ ;;; Support function updating n's inherited attribution w.r.t. a list of inherited attribute definitions:
+ (define update-by-defs
+ (lambda (n att-defs)
+ (for-each ;; Add new and update existing inherited attribute instances:
+ (lambda (att-def)
+ (let ((att (node-find-attribute n (attribute-definition-name att-def))))
+ (cond
+ ((not att)
+ (node-attributes-set! n (cons (make-attribute-instance att-def n) (node-attributes n))))
+ ((not (attribute-definition-synthesized? (attribute-instance-definition att)))
+ (if (eq?
+ (attribute-definition-equation (attribute-instance-definition att))
+ (attribute-definition-equation att-def))
+ (attribute-instance-definition-set! att att-def)
+ (begin
+ (flush-attribute-instance att)
+ (node-attributes-set!
+ n
+ (cons (make-attribute-instance att-def n) (remq att (node-attributes n))))))))))
+ att-defs)
+ (node-attributes-set! ; Delete all inherited attribute instances not defined anymore:
+ n
+ (remp
+ (lambda (att)
+ (let ((remove?
+ (and
+ (attribute-definition-inherited? (attribute-instance-definition att))
+ (not (memq (attribute-instance-definition att) att-defs)))))
+ (when remove?
+ (flush-attribute-instance att))
+ remove?))
+ (node-attributes n)))))
+ ;;; Perform the update:
+ (let* ((parent (node-parent n))
+ (att-defs
+ (cond
+ ((not parent)
+ (list))
+ ((not (node-list-node? parent))
+ (symbol-attributes
+ (list-ref
+ (ast-rule-production (node-ast-rule parent))
+ (node-child-index? n))))
+ ((node-parent parent)
+ (symbol-attributes
+ (list-ref
+ (ast-rule-production (node-ast-rule (node-parent parent)))
+ (node-child-index? parent))))
+ (else (list)))))
+ (if (node-list-node? n)
+ (for-each
+ (lambda (n)
+ (unless (node-bud-node? n)
+ (update-by-defs n att-defs)))
+ (node-children n))
+ (unless (node-bud-node? n)
+ (update-by-defs n att-defs))))))
+
+ ;; INTERNAL FUNCTION: Given an AST node delete its inherited attribute instances. Iff the given node
+ ;; is a list node, the inherited attributes of its elements are deleted.
+ (define detach-inherited-attributes
+ (lambda (n)
+ (cond
+ ((node-list-node? n)
+ (for-each
+ detach-inherited-attributes
+ (node-children n)))
+ ((node-non-terminal? n)
+ (node-attributes-set!
+ n
+ (remp
+ (lambda (att)
+ (let ((remove? (attribute-definition-inherited? (attribute-instance-definition att))))
+ (when remove?
+ (flush-attribute-instance att))
+ remove?))
+ (node-attributes n)))))))
+
+ ;; INTERNAL FUNCTION: Given an evaluator state and an AST fragment, change the
+ ;; fragment's evaluator state to the given one.
+ (define distribute-evaluator-state
+ (lambda (evaluator-state n)
+ (node-evaluator-state-set! n evaluator-state)
+ (unless (node-terminal? n)
+ (for-each
+ (lambda (n)
+ (distribute-evaluator-state evaluator-state n))
+ (node-children n)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Dependency Tracking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-upwards
+ (lambda (influencing-node)
+ (add-dependency:cache->node-characteristic influencing-node (cons 0 'up))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-downwards
+ (lambda (influencing-node)
+ (add-dependency:cache->node-characteristic influencing-node (cons 0 'down))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-is-root
+ (lambda (influencing-node)
+ (add-dependency:cache->node-characteristic influencing-node (cons 1 racr-nil))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-num-children
+ (lambda (influencing-node)
+ (add-dependency:cache->node-characteristic influencing-node (cons 2 racr-nil))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-type
+ (lambda (influencing-node)
+ (add-dependency:cache->node-characteristic influencing-node (cons 3 racr-nil))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-super-type
+ (lambda (influencing-node comparision-type)
+ (add-dependency:cache->node-characteristic influencing-node (cons 4 comparision-type))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-sub-type
+ (lambda (influencing-node comparision-type)
+ (add-dependency:cache->node-characteristic influencing-node (cons 5 comparision-type))))
+
+ ;; INTERNAL FUNCTION: See "add-dependency:cache->node-characteristic".
+ (define add-dependency:cache->node-defines-context
+ (lambda (influencing-node context-name)
+ (add-dependency:cache->node-characteristic influencing-node (cons 6 context-name))))
+
+ ;; INTERNAL FUNCTION: Given a node N and a correlation C add an dependency-edge marked with C from
+ ;; the attribute cache entry currently in evaluation (considering the evaluator state of the AST N
+ ;; is part of) to N and an influence-edge vice versa. If no attribute cache entry is in evaluation
+ ;; no edges are added. The following seven correlations exist:
+ ;; 0) Dependency on the existence of the node w.r.t. a query from a certain direction encoded in C (i.e.,
+ ;; existence of a node at the same location queried from the same direction (upwards or downwards the AST))
+ ;; 1) Dependency on the node being a root (i.e., the node has no parent)
+ ;; 2) Dependency on the node's number of children (i.e., existence of a node at the same location and with
+ ;; the same number of children)
+ ;; 3) Dependency on the node's type (i.e., existence of a node at the same location and with the same type)
+ ;; 4) Dependency on whether the node's type is a supertype w.r.t. a certain type encoded in C or not
+ ;; 5) Dependency on whether the node's type is a subtype w.r.t. a certain type encoded in C or not
+ ;; 6) Dependency on whether the node defines a certain context (i.e., has child with a certain name) or not
+ (define add-dependency:cache->node-characteristic
+ (lambda (influencing-node correlation)
+ (let ((dependent-cache (evaluator-state-in-evaluation? (node-evaluator-state influencing-node))))
+ (when dependent-cache
+ (let ((dependency-vector
+ (let ((dc-hit (assq influencing-node (attribute-cache-entry-node-dependencies dependent-cache))))
+ (and dc-hit (cdr dc-hit)))))
+ (unless dependency-vector
+ (set! dependency-vector (vector #f #f #f #f (list) (list) (list)))
+ (attribute-cache-entry-node-dependencies-set!
+ dependent-cache
+ (cons
+ (cons influencing-node dependency-vector)
+ (attribute-cache-entry-node-dependencies dependent-cache)))
+ (node-cache-influences-set!
+ influencing-node
+ (cons
+ (cons dependent-cache dependency-vector)
+ (node-cache-influences influencing-node))))
+ (let ((correlation-type (car correlation))
+ (correlation-arg (cdr correlation)))
+ (vector-set!
+ dependency-vector
+ correlation-type
+ (case correlation-type
+ ((0)
+ (let ((known-direction (vector-ref dependency-vector correlation-type)))
+ (cond
+ ((not known-direction) correlation-arg)
+ ((eq? known-direction correlation-arg) known-direction)
+ (else 'up/down))))
+ ((1 2 3)
+ #t)
+ ((4 5 6)
+ (let ((known-args (vector-ref dependency-vector correlation-type)))
+ (if (memq correlation-arg known-args)
+ known-args
+ (cons correlation-arg known-args))))))))))))
+
+ ;; INTERNAL FUNCTION: Given an attribute cache entry C, add an dependency-edge from C to the entry currently
+ ;; in evaluation (considering the evaluator state of the AST C is part of) and an influence-edge vice-versa.
+ ;; If no attribute cache entry is in evaluation no edges are added.
+ (define add-dependency:cache->cache
+ (lambda (influencing-cache)
+ (let ((dependent-cache
+ (evaluator-state-in-evaluation?
+ (node-evaluator-state
+ (attribute-instance-context
+ (attribute-cache-entry-context influencing-cache))))))
+ (when (and dependent-cache (not (memq influencing-cache (attribute-cache-entry-cache-dependencies dependent-cache))))
+ (attribute-cache-entry-cache-dependencies-set!
+ dependent-cache
+ (cons
+ influencing-cache
+ (attribute-cache-entry-cache-dependencies dependent-cache)))
+ (attribute-cache-entry-cache-influences-set!
+ influencing-cache
+ (cons
+ dependent-cache
+ (attribute-cache-entry-cache-influences influencing-cache)))))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Abstract Syntax Tree Rewriting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; INTERNAL FUNCTION: Given an attribute instance, flush all its cache entries.
+ (define flush-attribute-instance
+ (lambda (att)
+ (call-with-values
+ (lambda ()
+ (hashtable-entries (attribute-instance-cache att)))
+ (lambda (keys values)
+ (vector-for-each
+ flush-attribute-cache-entry
+ values)))))
+
+ ;; INTERNAL FUNCTION: Given an attribute cache entry, delete it and all depending entries.
+ (define flush-attribute-cache-entry
+ (lambda (att-cache)
+ (let ((influenced-caches (attribute-cache-entry-cache-influences att-cache))) ; Save all influenced attribute cache entries.
+ ;; Delete foreign influences:
+ (for-each ; For every cache entry I the entry depends on,...
+ (lambda (influencing-cache)
+ (attribute-cache-entry-cache-influences-set! ; ...remove the influence edge from I to the entry.
+ influencing-cache
+ (remq att-cache (attribute-cache-entry-cache-influences influencing-cache))))
+ (attribute-cache-entry-cache-dependencies att-cache))
+ (for-each ; For every node N the attribute cache entry depends on...
+ (lambda (node-dependency)
+ (node-cache-influences-set!
+ (car node-dependency)
+ (remp ; ...remove the influence edge from N to the entry.
+ (lambda (cache-influence)
+ (eq? (car cache-influence) att-cache))
+ (node-cache-influences (car node-dependency)))))
+ (attribute-cache-entry-node-dependencies att-cache))
+ ;; Delete the attribute cache entry:
+ (hashtable-delete!
+ (attribute-instance-cache (attribute-cache-entry-context att-cache))
+ (attribute-cache-entry-arguments att-cache))
+ (attribute-cache-entry-cache-dependencies-set! att-cache (list))
+ (attribute-cache-entry-node-dependencies-set! att-cache (list))
+ (attribute-cache-entry-cache-influences-set! att-cache (list))
+ ;; Proceed flushing, i.e., for every attribute cache entry D the entry originally influenced,...
+ (for-each
+ (lambda (dependent-cache)
+ (flush-attribute-cache-entry dependent-cache)) ; ...flush D.
+ influenced-caches))))
+
+ ;; INTERNAL FUNCTION: Given an AST node n, flush all attribute cache entries that depend on
+ ;; information of the subtree spaned by n but are outside of it and, if requested, all attribute
+ ;; cache entries within the subtree spaned by n that depend on information outside of it.
+ (define flush-inter-fragment-dependent-attribute-cache-entries
+ (lambda (n flush-outgoing?)
+ (let loop ((n* n))
+ (for-each
+ (lambda (influence)
+ (unless (node-inside-of? (attribute-instance-context (attribute-cache-entry-context (car influence))) n)
+ (flush-attribute-cache-entry (car influence))))
+ (node-cache-influences n*))
+ (for-each
+ (lambda (att)
+ (vector-for-each
+ (lambda (att-cache)
+ (let ((flush-att-cache?
+ (and
+ flush-outgoing?
+ (or
+ (find
+ (lambda (dependency)
+ (not (node-inside-of? (car dependency) n)))
+ (attribute-cache-entry-node-dependencies att-cache))
+ (find
+ (lambda (influencing-cache)
+ (not (node-inside-of? (attribute-instance-context (attribute-cache-entry-context influencing-cache)) n)))
+ (attribute-cache-entry-cache-dependencies att-cache))))))
+ (if flush-att-cache?
+ (flush-attribute-cache-entry att-cache)
+ (for-each
+ (lambda (dependent-cache)
+ (unless (node-inside-of? (attribute-instance-context (attribute-cache-entry-context dependent-cache)) n)
+ (flush-attribute-cache-entry dependent-cache)))
+ (attribute-cache-entry-cache-influences att-cache)))))
+ (call-with-values
+ (lambda ()
+ (hashtable-entries (attribute-instance-cache att)))
+ (lambda (key-vector value-vector)
+ value-vector))))
+ (node-attributes n*))
+ (unless (node-terminal? n*)
+ (for-each
+ loop
+ (node-children n*))))))
+
+ (define rewrite-terminal
+ (lambda (i n new-value)
+ ;;; Before changing the value of the terminal ensure, that...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state n)) ; ...no attributes are in evaluation and...
+ (throw-exception
+ "Cannot change terminal value; "
+ "There are attributes in evaluation."))
+ (let ((n
+ (if (symbol? i)
+ (node-find-child n i)
+ (and (>= i 1) (<= i (length (node-children n))) (list-ref (node-children n) (- i 1))))))
+ (unless (and n (node-terminal? n)) ; ...the given context is a terminal.
+ (throw-exception
+ "Cannot change terminal value; "
+ "The given context does not exist or is no terminal."))
+ ;;; Everything is fine. Thus,...
+ (let ((old-value (node-children n)))
+ (for-each ; ...flush all attribute cache entries influenced by the terminal,...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (node-cache-influences n))
+ (node-children-set! n new-value) ; ...rewrite its value and...
+ old-value)))) ; ...return its old value.
+
+ (define rewrite-refine
+ (lambda (n t . c)
+ ;;; Before refining the non-terminal node ensure, that...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state n)) ; ...non of its attributes are in evaluation,...
+ (throw-exception
+ "Cannot refine node; "
+ "There are attributes in evaluation."))
+ (when (or (node-list-node? n) (node-bud-node? n)) ; ...it is not a list or bud node,...
+ (throw-exception
+ "Cannot refine node; "
+ "The node is a " (if (node-list-node? n) "list" "bud") " node."))
+ (let* ((old-rule (node-ast-rule n))
+ (new-rule (racr-specification-find-rule (ast-rule-specification old-rule) t)))
+ (unless (and new-rule (ast-rule-subtype? new-rule old-rule)) ; ...the given type is a subtype and...
+ (throw-exception
+ "Cannot refine node; "
+ t " is not a subtype of " (symbol-name (car (ast-rule-production old-rule))) "."))
+ (let ((additional-children (list-tail (ast-rule-production new-rule) (length (ast-rule-production old-rule)))))
+ (unless (satisfies-contexts? c additional-children) ; ...all additional children fit.
+ (throw-exception
+ "Cannot refine node; "
+ "The given additional children do not fit."))
+ ;;; Everything is fine. Thus,...
+ (for-each ; ...flush the influenced attribute cache entries, i.e., all entries influenced by the node's...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (or
+ (and (vector-ref (cdr influence) 2) (not (null? c))) ; ...number of children,...
+ (and (vector-ref (cdr influence) 3) (not (eq? old-rule new-rule))) ; ...type,...
+ (find ; ...supertype,...
+ (lambda (t2)
+ (not (eq? (ast-rule-subtype? t2 old-rule) (ast-rule-subtype? t2 new-rule))))
+ (vector-ref (cdr influence) 4))
+ (find ; ...subtype or...
+ (lambda (t2)
+ (not (eq? (ast-rule-subtype? old-rule t2) (ast-rule-subtype? new-rule t2))))
+ (vector-ref (cdr influence) 5))
+ (find ; ...defined contexts and...
+ (lambda (context-name)
+ (let ((old-defines-context? (ast-rule-find-child-context old-rule context-name))
+ (new-defines-context? (ast-rule-find-child-context new-rule context-name)))
+ (if old-defines-context? (not new-defines-context?) new-defines-context?)))
+ (vector-ref (cdr influence) 6))))
+ (node-cache-influences n)))
+ (for-each ; ...all entries depending on the new children being roots. Afterwards,...
+ (lambda (child context)
+ (when (symbol-non-terminal? context)
+ (for-each
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 1))
+ (node-cache-influences child)))))
+ c
+ additional-children)
+ (node-ast-rule-set! n new-rule) ; ...update the node's type,...
+ (update-synthesized-attribution n) ; ...synthesized attribution,...
+ (node-children-set! ; ...insert the new children and...
+ n
+ (append
+ (node-children n)
+ (map
+ (lambda (child context)
+ (let ((child
+ (if (symbol-non-terminal? context)
+ child
+ (make-node 'terminal n child))))
+ (node-parent-set! child n)
+ (distribute-evaluator-state (node-evaluator-state n) child) ; ...update their evaluator state and...
+ child))
+ c
+ additional-children)))
+ (for-each
+ update-inherited-attribution ; ...inherited attribution.
+ (node-children n))))))
+
+ (define rewrite-abstract
+ (lambda (n t)
+ ;;; Before abstracting the node ensure, that...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state n)) ; ...no attributes are in evaluation,...
+ (throw-exception
+ "Cannot abstract node; "
+ "There are attributes in evaluation."))
+ (when (or (node-list-node? n) (node-bud-node? n)) ; ...the node is not a list or bud node,...
+ (throw-exception
+ "Cannot abstract node; "
+ "The node is a " (if (node-list-node? n) "list" "bud") " node."))
+ (let* ((old-rule (node-ast-rule n))
+ (new-rule (racr-specification-find-rule (ast-rule-specification old-rule) t)))
+ (unless (and new-rule (ast-rule-subtype? old-rule new-rule)) ; ...the new type is a supertype and...
+ (throw-exception
+ "Cannot abstract node; "
+ t " is not a supertype of " (symbol-name (car (ast-rule-production old-rule))) "."))
+ ; ...permitted in the context in which the node is:
+ (unless (or (not (node-parent n)) (valid-replacement-candidate? n (create-ast-mockup new-rule)))
+ (throw-exception
+ "Cannot abstract node; "
+ "Abstraction to type " t " not permitted by context."))
+ ;;; Everything is fine. Thus,...
+ (let* ((num-new-children (length (cdr (ast-rule-production new-rule))))
+ (children-to-remove (list-tail (node-children n) num-new-children)))
+ (for-each ; ...flush all influenced attribute cache entries, i.e., all entries influenced by the node's...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (or
+ (and (vector-ref (cdr influence) 2) (not (null? children-to-remove))) ; ...number of children,...
+ (and (vector-ref (cdr influence) 3) (not (eq? old-rule new-rule))) ; ...type...
+ (find ; ...supertype,...
+ (lambda (t2)
+ (not (eq? (ast-rule-subtype? t2 old-rule) (ast-rule-subtype? t2 new-rule))))
+ (vector-ref (cdr influence) 4))
+ (find ; ...subtype or...
+ (lambda (t2)
+ (not (eq? (ast-rule-subtype? old-rule t2) (ast-rule-subtype? new-rule t2))))
+ (vector-ref (cdr influence) 5))
+ (find ; ...defined contexts and...
+ (lambda (context-name)
+ (let ((old-defines-context? (ast-rule-find-child-context old-rule context-name))
+ (new-defines-context? (ast-rule-find-child-context new-rule context-name)))
+ (if old-defines-context? (not new-defines-context?) new-defines-context?)))
+ (vector-ref (cdr influence) 6))))
+ (node-cache-influences n)))
+ (for-each ; ...all entries cross-depending the removed ASTs. Afterwards,...
+ (lambda (child-to-remove)
+ (flush-inter-fragment-dependent-attribute-cache-entries child-to-remove #t))
+ children-to-remove)
+ (node-ast-rule-set! n new-rule) ; ...update the node's type and its...
+ (update-synthesized-attribution n) ; ...synthesized (because of possibly less) and...
+ (update-inherited-attribution n) ; ...inherited (because of unshadowed) attributes. Further,...
+ (for-each ; ...for every child to remove,...
+ (lambda (child)
+ (detach-inherited-attributes child) ; ...delete its inherited attributes,...
+ (node-parent-set! child #f) ; ...detach it from the AST and...
+ (distribute-evaluator-state (make-evaluator-state) child)) ; ...update its evaluator state. Then,...
+ children-to-remove)
+ (unless (null? children-to-remove)
+ (if (> num-new-children 0)
+ (set-cdr! (list-tail (node-children n) (- num-new-children 1)) (list))
+ (node-children-set! n (list))))
+ (for-each ; ...update the inherited attribution of all remaining children. Finally,...
+ update-inherited-attribution
+ (node-children n))
+ (map ; ...return the removed children.
+ (lambda (child) (if (node-terminal? child) (node-children child) child))
+ children-to-remove)))))
+
+ (define rewrite-subtree
+ (lambda (old-fragment new-fragment)
+ ;;; Before replacing the subtree ensure, that no attributes of the old fragment are in evaluation and...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state old-fragment))
+ (throw-exception
+ "Cannot replace subtree; "
+ "There are attributes in evaluation."))
+ (unless (valid-replacement-candidate? old-fragment new-fragment) ; ...the new fragment fits in its context.
+ (throw-exception
+ "Cannot replace subtree; "
+ "The replacement does not fit."))
+ ;;; When all rewrite constraints are satisfied,...
+ (detach-inherited-attributes old-fragment) ; ...delete the old fragment's inherited attribution. Then,...
+ ; ...flush all attribute cache entries cross-depending the old fragment and...
+ (flush-inter-fragment-dependent-attribute-cache-entries old-fragment #t)
+ (for-each ; ...all entries depending on the new fragment being a root. Afterwards,...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 1))
+ (node-cache-influences new-fragment)))
+ (distribute-evaluator-state (node-evaluator-state old-fragment) new-fragment) ; ...update both fragments' evaluator state,...
+ (distribute-evaluator-state (make-evaluator-state) old-fragment)
+ (set-car! ; ...replace the old fragment by the new one and...
+ (list-tail (node-children (node-parent old-fragment)) (- (node-child-index? old-fragment) 1))
+ new-fragment)
+ (node-parent-set! new-fragment (node-parent old-fragment))
+ (node-parent-set! old-fragment #f)
+ (update-inherited-attribution new-fragment) ; ...update the new fragment's inherited attribution. Finally,...
+ old-fragment)) ; ...return the removed old fragment.
+
+ (define rewrite-add
+ (lambda (l e)
+ ;;; Before adding the element ensure, that...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state l)) ; ...no attributes of the list are in evaluation,...
+ (throw-exception
+ "Cannot add list element; "
+ "There are attributes in evaluation."))
+ (unless (node-list-node? l) ; ...indeed a list is given as context and...
+ (throw-exception
+ "Cannot add list element; "
+ "The given context is no list-node."))
+ (unless (valid-list-element-candidate? l e) ; ...the new element fits.
+ (throw-exception
+ "Cannot add list element; "
+ "The new element does not fit."))
+ ;;; When all rewrite constraints are satisfied,...
+ (for-each ; ...flush all attribute cache entries influenced by the list-node's number of children and...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 2))
+ (node-cache-influences l)))
+ (for-each ; ...all entries depending on the new element being a root. Afterwards,...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 1))
+ (node-cache-influences e)))
+ (node-children-set! l (append (node-children l) (list e))) ; ...add the new element,...
+ (node-parent-set! e l)
+ (distribute-evaluator-state (node-evaluator-state l) e) ; ...initialize its evaluator state and...
+ (when (node-parent l)
+ (update-inherited-attribution e)))) ; ...any inherited attributes defined for its new context.
+
+ (define rewrite-insert
+ (lambda (l i e)
+ ;;; Before inserting the new element ensure, that...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state l)) ; ...no attributes of the list are in evaluation,...
+ (throw-exception
+ "Cannot insert list element; "
+ "There are attributes in evaluation."))
+ (unless (node-list-node? l) ; ...indeed a list is given as context,...
+ (throw-exception
+ "Cannot insert list element; "
+ "The given context is no list-node."))
+ (when (or (< i 1) (> i (+ (length (node-children l)) 1))) ; ...the list has enough elements and...
+ (throw-exception
+ "Cannot insert list element; "
+ "The given index is out of range."))
+ (unless (valid-list-element-candidate? l e) ; ...the new element fits.
+ (throw-exception
+ "Cannot add list element; "
+ "The new element does not fit."))
+ ;;; When all rewrite constraints are satisfied...
+ (for-each ; ...flush all attribute cache entries influenced by the list's number of children. Further,...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 2))
+ (node-cache-influences l)))
+ (for-each ; ...for each successor element after insertion,...
+ (lambda (successor)
+ (for-each ; ...flush all attribute cache entries depending on the respective element...
+ (lambda (influence)
+ (define query-direction? (vector-ref (cdr influence) 0)) ; ...via a downwards query. Then,...
+ (when (or (eq? query-direction? 'down) (eq? query-direction? 'up/down))
+ (flush-attribute-cache-entry (car influence))))
+ (node-cache-influences successor)))
+ (list-tail (node-children l) (- i 1)))
+ (for-each ; ...flush all attribute cache entries depending on the new element being a root. Afterwards,...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (vector-ref (cdr influence) 1))
+ (node-cache-influences e)))
+ (cond ; ...insert the new element,...
+ ((null? (node-children l))
+ (node-children-set! l (list e)))
+ ((= (length (node-children l)) (- i 1))
+ (node-children-set! l (append (node-children l) (list e))))
+ (else
+ (let ((insert-head (list-tail (node-children l) (- i 1))))
+ (set-cdr! insert-head (cons (car insert-head) (cdr insert-head)))
+ (set-car! insert-head e))))
+ (node-parent-set! e l)
+ (distribute-evaluator-state (node-evaluator-state l) e) ; ...initialize its evaluator state and...
+ (when (node-parent l)
+ (update-inherited-attribution e)))) ; ...any inherited attributes defined for its new context.
+
+ (define rewrite-delete
+ (lambda (n)
+ ;;; Before deleting the element ensure, that...
+ (when (evaluator-state-in-evaluation? (node-evaluator-state n)) ; ...no attributes are in evaluation and...
+ (throw-exception
+ "Cannot delete list element; "
+ "There are attributes in evaluation."))
+ (unless (and (node-parent n) (node-list-node? (node-parent n))) ; ...the given node is element of a list.
+ (throw-exception
+ "Cannot delete list element; "
+ "The given node is not element of a list."))
+ ;;; When all rewrite constraints are satisfied,...
+ (detach-inherited-attributes n) ; ...delete the element's inherited attributes and...
+ (for-each ; ...flush all attribute cache entries influenced by...
+ (lambda (influence)
+ (flush-attribute-cache-entry (car influence)))
+ (filter
+ (lambda (influence)
+ (or (vector-ref (cdr influence) 2) ; ...the number of children of the list node the element is part of or...
+ (let ((query-direction? (vector-ref (cdr influence) 0))) ; ...that query the list node via...
+ (and (or (eq? query-direction? 'up) (eq? query-direction? 'up/down)) ; ...an upwards query and...
+ (node-inside-of? ; ...are within the element's subtree. Also flush,...
+ (attribute-instance-context (attribute-cache-entry-context (car influence)))
+ n)))))
+ (node-cache-influences (node-parent n))))
+ (for-each ; ...for the element itself and each successor element,...
+ (lambda (successor)
+ (for-each ; ...all attribute cache entries depending on the respective element...
+ (lambda (influence)
+ (define query-direction? (vector-ref (cdr influence) 0)) ; ...via a downwards query. Finally,...
+ (when (or (eq? query-direction? 'down) (eq? query-direction? 'up/down))
+ (flush-attribute-cache-entry (car influence))))
+ (node-cache-influences successor)))
+ (list-tail (node-children (node-parent n)) (- (node-child-index? n) 1)))
+ (node-children-set! (node-parent n) (remq n (node-children (node-parent n)))) ; ...remove the element from the list,...
+ (node-parent-set! n #f)
+ (distribute-evaluator-state (make-evaluator-state) n) ; ...reset its evaluator state and...
+ n)) ; ...return it.
+
+ (define perform-rewrites
+ (lambda (n strategy . transformers)
+ (define root
+ (let loop ((n n))
+ (if (ast-has-parent? n)
+ (loop (ast-parent n))
+ n)))
+ (define root-deleted/inserted?
+ (let ((evaluator-state (node-evaluator-state root)))
+ (lambda ()
+ (not (eq? evaluator-state (node-evaluator-state root))))))
+ (define find-and-apply
+ (case strategy
+ ((top-down)
+ (lambda (n)
+ (and
+ (not (node-terminal? n))
+ (or
+ (find (lambda (transformer) (transformer n)) transformers)
+ (find find-and-apply (node-children n))))))
+ ((bottom-up)
+ (lambda (n)
+ (and
+ (not (node-terminal? n))
+ (or
+ (find find-and-apply (node-children n))
+ (find (lambda (transformer) (transformer n)) transformers)))))
+ (else (throw-exception
+ "Cannot perform rewrites; "
+ "Unknown " strategy " strategy."))))
+ (let loop ()
+ (when (root-deleted/inserted?)
+ (throw-exception
+ "Cannot perform rewrites; "
+ "A given transformer manipulated the root of the AST."))
+ (let ((match (find-and-apply root)))
+ (if match
+ (cons match (loop))
+ (list))))))
+
+ (define create-transformer-for-pattern
+ (lambda (spec node-type pattern-attribute rewrite-function . pattern-arguments)
+ (let ((ast-rule (specification->find-ast-rule spec node-type)))
+ (unless ast-rule
+ (throw-exception
+ "Cannot construct transformer; "
+ "Undefined " node-type " node type."))
+ (unless (find
+ (lambda (attribute-definition)
+ (eq? (attribute->name attribute-definition) pattern-attribute))
+ (symbol->attributes (car (ast-rule->production ast-rule))))
+ (throw-exception
+ "Cannot construct transformer; "
+ "No " pattern-attribute " attribute defined in the context of " node-type " nodes.")))
+ (lambda (n)
+ (when (and (not (or (ast-bud-node? n) (ast-list-node? n))) (ast-subtype? n node-type))
+ (let ((match? (apply att-value pattern-attribute n pattern-arguments)))
+ (if match?
+ (or
+ (apply rewrite-function match? pattern-arguments)
+ #t)
+ #f))))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Pattern Matching ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define pattern-language (make-racr-specification))
+
+ ;;; Pattern Specification:
+
+ (define specify-pattern
+ (lambda (spec att-name distinguished-node fragments references condition?)
+ (define process-fragment
+ (lambda (context type binding children)
+ (unless (and
+ (or (symbol? context) (integer? context))
+ (or (not type) (symbol? type))
+ (or (not binding) (symbol? binding)))
+ (throw-exception
+ "Invalid pattern definition; "
+ "Wrong argument type (context, type or binding of fragment)."))
+ (create-ast
+ pattern-language
+ 'Node
+ (list
+ context
+ type
+ binding
+ (create-ast-list
+ (map
+ (lambda (child)
+ (apply process-fragment child))
+ children))))))
+ (define process-reference
+ (lambda (name source target)
+ (unless (and (symbol? name) (symbol? source) (symbol? target))
+ (throw-exception
+ "Invalid pattern definition; "
+ "Wrong argument type (name, source and target of references must be symbols)."))
+ (create-ast pattern-language 'Ref (list name source target))))
+ (let ((ast
+ (create-ast
+ pattern-language
+ 'Pattern
+ (list
+ (create-ast-list (map (lambda (frag) (apply process-fragment (cons 'racr-nil frag))) fragments))
+ (create-ast-list (map (lambda (ref) (apply process-reference ref)) references))
+ #f
+ spec))))
+ ;; Resolve symbolic node references (i.e., perform name analysis):
+ (rewrite-terminal 'dnode ast (att-value 'lookup-node ast distinguished-node))
+ (for-each
+ (lambda (ref)
+ (let ((source? (att-value 'lookup-node ast (ast-child 'source ref)))
+ (target? (att-value 'lookup-node ast (ast-child 'target ref))))
+ (if source?
+ (rewrite-terminal 'source ref source?)
+ (throw-exception
+ "Invalid pattern definition; "
+ "Undefined reference source " (ast-child 'source ref) "."))
+ (if target?
+ (rewrite-terminal 'target ref target?)
+ (throw-exception
+ "Invalid pattern definition; "
+ "Undefined reference target " (ast-child 'target ref) "."))))
+ (ast-children (ast-child 'Ref* ast)))
+ ;; Ensure well-formedness of the pattern (valid distinguished node, reachability, typing, unique node naming):
+ (unless (att-value 'well-formed? ast)
+ (throw-exception
+ "Invalid pattern definition; "
+ "The pattern is not well-formed."))
+ ; Every thing is fine. Thus, add a respective matching attribute to the given specification:
+ (specify-attribute
+ spec
+ att-name
+ (ast-child 'type (ast-child 'dnode ast))
+ '*
+ #t
+ (let ((pmm (att-value 'pmm-code ast))) ; Precompute the PMM => The pattern AST is not in the equation's closure
+ (if condition?
+ (lambda (n . args)
+ (let ((bindings (pmm n)))
+ (if (and bindings (apply condition? bindings args))
+ bindings
+ #f)))
+ pmm))
+ #f))))
+
+ ;;; Pattern Matching Machine:
+
+ (define pmmi-load-node ; Make already stored node the new current one.
+ (lambda (next-instruction index)
+ (lambda (current-node node-memory)
+ (next-instruction (vector-ref node-memory index) node-memory))))
+
+ (define pmmi-store-node ; Store current node for later reference.
+ (lambda (next-instruction index)
+ (lambda (current-node node-memory)
+ (vector-set! node-memory index current-node)
+ (next-instruction current-node node-memory))))
+
+ (define pmmi-ensure-context-by-name ; Ensure, the current node is certain child & make its parent the new current node.
+ (lambda (next-instruction context-name)
+ (lambda (current-node node-memory)
+ (let ((parent? (ast-has-parent? current-node)))
+ (if (and parent? (ast-has-child? context-name parent?) (eq? (ast-child context-name parent?) current-node))
+ (next-instruction parent? node-memory)
+ #f)))))
+
+ (define pmmi-ensure-context-by-index ; Ensure, the current node is certain child & make its parent the new current node.
+ (lambda (next-instruction index)
+ (lambda (current-node node-memory)
+ (let ((parent? (ast-has-parent? current-node)))
+ (if (and parent? (>= (ast-num-children parent?) index) (eq? (ast-child index parent?) current-node))
+ (next-instruction parent? node-memory)
+ #f)))))
+
+ (define pmmi-ensure-subtype ; Ensure, the current node is of a certain type or a subtype.
+ (lambda (next-instruction super-type)
+ (lambda (current-node node-memory)
+ (if (and
+ (not (ast-list-node? current-node))
+ (not (ast-bud-node? current-node))
+ (ast-subtype? current-node super-type))
+ (next-instruction current-node node-memory)
+ #f))))
+
+ (define pmmi-ensure-list ; Ensure, the current node is a list node.
+ (lambda (next-instruction)
+ (lambda (current-node node-memory)
+ (if (ast-list-node? current-node)
+ (next-instruction current-node node-memory)
+ #f))))
+
+ (define pmmi-ensure-child-by-name ; Ensure, the current node has a certain child & make the child the new current node.
+ (lambda (next-instruction context-name)
+ (lambda (current-node node-memory)
+ (if (ast-has-child? context-name current-node)
+ (next-instruction (ast-child context-name current-node) node-memory)
+ #f))))
+
+ (define pmmi-ensure-child-by-index ; Ensure, the current node has a certain child & make the child the new current node.
+ (lambda (next-instruction index)
+ (lambda (current-node node-memory)
+ (if (>= (ast-num-children current-node) index)
+ (next-instruction (ast-child index current-node) node-memory)
+ #f))))
+
+ (define pmmi-ensure-node ; Ensure, the current node is a certain, already stored node.
+ (lambda (next-instruction index)
+ (lambda (current-node node-memory)
+ (if (eq? current-node (vector-ref node-memory index))
+ (next-instruction current-node node-memory)
+ #f))))
+
+ (define pmmi-traverse-reference ; Evaluate attribute of current node, ensure value is a node & make it the new current one.
+ (lambda (next-instruction reference-name)
+ (lambda (current-node node-memory)
+ (if (and (not (ast-bud-node? current-node)) (ast-node? (att-value reference-name current-node)))
+ (next-instruction (att-value reference-name current-node) node-memory)
+ #f))))
+
+ (define pmmi-terminate ; Construct association list of all binded nodes.
+ (lambda (bindings)
+ (let ((bindings ; Precompute list of (key, index) pairs => The pattern AST is not in the instruction's closure
+ (map
+ (lambda (n)
+ (cons (ast-child 'binding n) (att-value 'node-memory-index n)))
+ bindings)))
+ (lambda (current-node node-memory)
+ (map
+ (lambda (binding)
+ (cons (car binding) (vector-ref node-memory (cdr binding))))
+ bindings)))))
+
+ (define pmmi-initialize ; First instruction of any PMM program. Allocates memory used to store nodes throughout matching.
+ (lambda (next-instruction node-memory-size)
+ (lambda (current-node)
+ (next-instruction current-node (make-vector node-memory-size)))))
+
+ ;;; Pattern Language:
+
+ (define load-pattern-language
+ (lambda ()
+ (with-specification
+ pattern-language
+
+ (ast-rule 'Pattern->Node*-Ref*-dnode-spec)
+ (ast-rule 'Node->context-type-binding-Node*)
+ (ast-rule 'Ref->name-source-target)
+ (compile-ast-specifications 'Pattern)
+
+ ;;; Name Analysis:
+
+ (ag-rule ; Given a binding name, find its respective binded node.
+ lookup-node
+ (Pattern
+ (lambda (n name)
+ (ast-find-child*
+ (lambda (i n)
+ (att-value 'local-lookup-node n name))
+ (ast-child 'Node* n)))))
+
+ (ag-rule
+ local-lookup-node
+ (Node
+ (lambda (n name)
+ (if (eq? (ast-child 'binding n) name)
+ n
+ (ast-find-child*
+ (lambda (i n)
+ (att-value 'local-lookup-node n name))
+ (ast-child 'Node* n))))))
+
+ (ag-rule ; Given a non-terminal, find its respective RACR AST rule.
+ lookup-type
+ (Pattern
+ (lambda (n type)
+ (specification->find-ast-rule (ast-child 'spec n) type))))
+
+ ;;; Abstract Syntax Tree Query Support:
+
+ (ag-rule ; Root of the AST fragment a node is part of.
+ fragment-root
+ ((Pattern Node*)
+ (lambda (n)
+ n)))
+
+ (ag-rule ; Is the node a fragment root?
+ fragment-root?
+ ((Pattern Node*)
+ (lambda (n) #t))
+ ((Node Node*)
+ (lambda (n) #f)))
+
+ (ag-rule ; List of all references of the pattern.
+ references
+ (Pattern
+ (lambda (n)
+ (ast-children (ast-child 'Ref* n)))))
+
+ (ag-rule ; List of all named nodes of the pattern.
+ bindings
+ (Pattern
+ (lambda (n)
+ (fold-left
+ (lambda (result n)
+ (append result (att-value 'bindings n)))
+ (list)
+ (ast-children (ast-child 'Node* n)))))
+ (Node
+ (lambda (n)
+ (fold-left
+ (lambda (result n)
+ (append result (att-value 'bindings n)))
+ (if (ast-child 'binding n) (list n) (list))
+ (ast-children (ast-child 'Node* n))))))
+
+ (ag-rule ; Number of pattern nodes of the pattern/the subtree spaned by a node (including the node itself).
+ nodes-count
+ (Pattern
+ (lambda (n)
+ (fold-left
+ (lambda (result n)
+ (+ result (att-value 'nodes-count n)))
+ 0
+ (ast-children (ast-child 'Node* n)))))
+ (Node
+ (lambda (n)
+ (fold-left
+ (lambda (result n)
+ (+ result (att-value 'nodes-count n)))
+ 1
+ (ast-children (ast-child 'Node* n))))))
+
+ ;;; Type Analysis:
+
+ (ag-rule ; Must the node be a list?
+ must-be-list?
+ (Node ; A node must be a list if:
+ (lambda (n)
+ (or
+ (eq? (ast-child 'type n) '*) ; (1) the pattern developer defines so,
+ (ast-find-child ; (2) any of its children is referenced by index.
+ (lambda (i n)
+ (integer? (ast-child 'context n)))
+ (ast-child 'Node* n))))))
+
+ (ag-rule ; Must the node not be a list?
+ must-not-be-list?
+ (Node ; A node must not be a list if:
+ (lambda (n)
+ (or
+ (and ; (1) the pattern developer defines so,
+ (ast-child 'type n)
+ (not (eq? (ast-child 'type n) '*)))
+ (and ; (2) it is child of a list,
+ (not (att-value 'fragment-root? n))
+ (att-value 'must-be-list? (ast-parent n)))
+ (ast-find-child ; (3) any of its children is referenced by name or must be a list.
+ (lambda (i n)
+ (or
+ (symbol? (ast-child 'context n))
+ (att-value 'must-be-list? n)))
+ (ast-child 'Node* n))))))
+
+ (ag-rule ; List of all types being subject of a Kleene closure, i.e., all list types.
+ most-general-list-types
+ (Pattern
+ (lambda (n)
+ (let ((list-types
+ (fold-left
+ (lambda (result ast-rule)
+ (fold-left
+ (lambda (result symbol)
+ (if (and (symbol->kleene? symbol) (not (memq (symbol->non-terminal? symbol) result)))
+ (cons (symbol->non-terminal? symbol) result)
+ result))
+ result
+ (cdr (ast-rule->production ast-rule))))
+ (list)
+ (att-value 'most-concrete-types n))))
+ (filter
+ (lambda (type1)
+ (not
+ (find
+ (lambda (type2)
+ (and
+ (not (eq? type1 type2))
+ (ast-rule-subtype? type1 type2)))
+ list-types)))
+ list-types)))))
+
+ (ag-rule ; List of all types (of a certain type) no other type inherits from.
+ most-concrete-types
+ (Pattern
+ (case-lambda
+ ((n)
+ (filter
+ (lambda (type)
+ (null? (ast-rule-subtypes type)))
+ (specification->ast-rules (ast-child 'spec n))))
+ ((n type)
+ (filter
+ (lambda (type)
+ (null? (ast-rule-subtypes type)))
+ (cons type (ast-rule-subtypes type)))))))
+
+ (ag-rule ; Satisfies a certain type a node's user defined type constraints?
+ valid-user-induced-type?
+ (Node
+ (lambda (n type kleene?)
+ (or
+ (not (ast-child 'type n))
+ (if (eq? (ast-child 'type n) '*)
+ kleene?
+ (let ((user-induced-type (att-value 'lookup-type n (ast-child 'type n))))
+ (and
+ user-induced-type
+ (ast-rule-subtype? type user-induced-type))))))))
+
+ (ag-rule ; Satisfies a certain type all type constraint of a node and its subtree?
+ valid-type?
+ (Node
+ (lambda (n type kleene?)
+ (and
+ (not (and (att-value 'must-be-list? n) (not kleene?)))
+ (not (and (att-value 'must-not-be-list? n) kleene?))
+ (att-value 'valid-user-induced-type? n type kleene?)
+ (if kleene?
+ (not
+ (ast-find-child
+ (lambda (i child)
+ (not
+ (find
+ (lambda (child-type)
+ (att-value 'valid-type? child child-type #f))
+ (att-value 'most-concrete-types n type))))
+ (ast-child 'Node* n)))
+ (not
+ (ast-find-child
+ (lambda (i child)
+ (let* ((context? (ast-rule-find-child-context type (ast-child 'context child)))
+ (context-types?
+ (cond
+ ((not (and context? (symbol->non-terminal? context?))) (list))
+ ((symbol->kleene? context?) (list (symbol->non-terminal? context?)))
+ (else (att-value 'most-concrete-types n (symbol->non-terminal? context?))))))
+ (not
+ (find
+ (lambda (type)
+ (att-value 'valid-type? child type (symbol->kleene? context?)))
+ context-types?))))
+ (ast-child 'Node* n))))))))
+
+ (ag-rule ; Is the pattern satisfiable (a matching AST exists regarding fragment syntax & type constraints)?
+ well-typed?
+ ((Pattern Node*)
+ (lambda (n)
+ (or
+ (find
+ (lambda (type)
+ (att-value 'valid-type? n type #f))
+ (att-value 'most-concrete-types n))
+ (find
+ (lambda (type)
+ (att-value 'valid-type? n type #t))
+ (att-value 'most-general-list-types n))))))
+
+ ;;; Reachability:
+
+ (ag-rule ; Is the reference connecting two different fragments?
+ inter-fragment-reference?
+ (Ref
+ (lambda (n)
+ (not
+ (eq?
+ (att-value 'fragment-root (ast-child 'source n))
+ (att-value 'fragment-root (ast-child 'target n)))))))
+
+ (ag-rule ; List of the child contexts to follow to reach the root.
+ fragment-root-path
+
+ ((Pattern Node*)
+ (lambda (n)
+ (list)))
+
+ ((Node Node*)
+ (lambda (n)
+ (cons (ast-child 'context n) (att-value 'fragment-root-path (ast-parent n))))))
+
+ (ag-rule ; List of the cheapest inter fragment references of a fragment and their respective costs.
+ inter-fragment-references
+ ((Pattern Node*)
+ (lambda (n)
+ (define walk-costs ; Sum of distances of a reference's source & target to their roots.
+ (lambda (ref)
+ (+
+ (length (att-value 'fragment-root-path (ast-child 'source ref)))
+ (length (att-value 'fragment-root-path (ast-child 'target ref))))))
+ (reverse
+ (fold-left ; Filter for each target the cheapest inter fragment reference:
+ (lambda (result ref)
+ (if
+ (memp
+ (lambda (weighted-ref)
+ (eq?
+ (att-value 'fragment-root (ast-child 'target ref))
+ (att-value 'fragment-root (ast-child 'target (car weighted-ref)))))
+ result)
+ result
+ (cons (cons ref (walk-costs ref)) result)))
+ (list)
+ (list-sort ; Sort the inter fragment references according to their costs:
+ (lambda (ref1 ref2)
+ (< (walk-costs ref1) (walk-costs ref2)))
+ (filter ; Find all inter fragment references of the fragment:
+ (lambda (ref)
+ (and
+ (eq? (att-value 'fragment-root (ast-child 'source ref)) n)
+ (att-value 'inter-fragment-reference? ref)))
+ (att-value 'references n))))))))
+
+ (ag-rule ; List of references best suited to reach other fragments from the distinguished node.
+ fragment-walk
+ (Pattern
+ (lambda (n)
+ (let ((dummy-walk
+ (cons
+ (create-ast 'Ref (list #f (ast-child 'dnode n) (ast-child 'dnode n)))
+ 0)))
+ (let loop ((walked ; List of pairs of already followed references and their total costs.
+ (list dummy-walk))
+ (to-visit ; Fragment roots still to visit.
+ (remq
+ (att-value 'fragment-root (ast-child 'dnode n))
+ (ast-children (ast-child 'Node* n)))))
+ (let ((next-walk? ; Find the next inter fragment reference to follow if there is any,...
+ (fold-left ; ...i.e., for every already walked inter fragment reference R,...
+ (lambda (best-next-walk performed-walk)
+ (let ((possible-next-walk ; ...find the best walk reaching a new fragment from its target....
+ (find
+ (lambda (weighted-ref)
+ (memq
+ (att-value 'fragment-root (ast-child 'target (car weighted-ref)))
+ to-visit))
+ (att-value 'inter-fragment-references (ast-child 'target (car performed-walk))))))
+ (cond
+ ((not possible-next-walk) ; ...If no new fragment is reachable from the target of R,...
+ best-next-walk) ; ...keep the currently best walk. Otherwise,...
+ ((not best-next-walk) ; ...if no next best walk has been selected yet,...
+ possible-next-walk) ; ...make the found one the best....
+ (else ; Otherwise,...
+ (let ((costs-possible-next-walk (+ (cdr possible-next-walk) (cdr performed-walk))))
+ (if (< costs-possible-next-walk (cdr best-next-walk)) ; ...select the better one.
+ (cons (car possible-next-walk) costs-possible-next-walk)
+ best-next-walk))))))
+ #f
+ walked)))
+ (if next-walk? ; If a new fragment can be reached,...
+ (loop ; ...try to find another reachable one. Otherwise,...
+ (append walked (list next-walk?))
+ (remq
+ (att-value 'fragment-root (ast-child 'target (car next-walk?)))
+ to-visit))
+ (map car (cdr walked))))))))) ; ...return the references defining all reachable fragments.
+
+ ;;; Well-formedness:
+
+ (ag-rule ; Is the pattern specification valid, such that PMM code can be generated?
+ well-formed?
+
+ (Pattern
+ (lambda (n)
+ (and
+ (att-value 'local-correct? n)
+ (not
+ (ast-find-child
+ (lambda (i n)
+ (not (att-value 'well-formed? n)))
+ (ast-child 'Node* n))))))
+
+ (Node
+ (lambda (n)
+ (and
+ (att-value 'local-correct? n)
+ (not
+ (ast-find-child
+ (lambda (i n)
+ (not (att-value 'well-formed? n)))
+ (ast-child 'Node* n)))))))
+
+ (ag-rule ; Is a certain part of the pattern AST valid?
+ local-correct?
+
+ (Pattern
+ (lambda (n)
+ (and
+ (ast-node? (ast-child 'dnode n)) ; A distinguished node must be defined, whose...
+ (ast-child 'type (ast-child 'dnode n)) ; ...type is user specified and...
+ (not (att-value 'must-be-list? (ast-child 'dnode n))) ; ...not a list.
+ (= ; All fragments must be reachable from the distinguished node:
+ (+ (length (att-value 'fragment-walk n)) 1)
+ (ast-num-children (ast-child 'Node* n)))
+ (not ; All fragments must be well typed, i.e., there exists an AST where they match:
+ (ast-find-child
+ (lambda (i n)
+ (not (att-value 'well-typed? n)))
+ (ast-child 'Node* n))))))
+
+ (Node
+ (lambda (n)
+ (and
+ (or ; Binded names must be unique:
+ (not (ast-child 'binding n))
+ (eq? (att-value 'lookup-node n (ast-child 'binding n)) n))
+ (let loop ((children (ast-children (ast-child 'Node* n)))) ; Contexts must be unique:
+ (cond
+ ((null? children) #t)
+ ((find
+ (lambda (child)
+ (eqv? (ast-child 'context (car children)) (ast-child 'context child)))
+ (cdr children))
+ #f)
+ (else (loop (cdr children)))))))))
+
+ ;;; Code generation:
+
+ (ag-rule ; Index within node memory. Used during pattern matching to store and later load matched nodes.
+ node-memory-index
+
+ ((Pattern Node*)
+ (lambda (n)
+ (if (> (ast-child-index n) 1)
+ (+
+ (att-value 'node-memory-index (ast-sibling (- (ast-child-index n) 1) n))
+ (att-value 'nodes-count (ast-sibling (- (ast-child-index n) 1) n)))
+ 0)))
+
+ ((Node Node*)
+ (lambda (n)
+ (if (> (ast-child-index n) 1)
+ (+
+ (att-value 'node-memory-index (ast-sibling (- (ast-child-index n) 1) n))
+ (att-value 'nodes-count (ast-sibling (- (ast-child-index n) 1) n)))
+ (+ (att-value 'node-memory-index (ast-parent n)) 1)))))
+
+ (ag-rule ; Function encoding pattern matching machine (PMM) specialised to match the pattern.
+ pmm-code
+ (Pattern
+ (lambda (n)
+ (pmmi-initialize
+ (att-value
+ 'pmm-code:match-fragment
+ (ast-child 'dnode n)
+ (fold-right
+ (lambda (reference result)
+ (pmmi-load-node
+ (pmmi-traverse-reference
+ (att-value 'pmm-code:match-fragment (ast-child 'target reference) result)
+ (ast-child 'name reference))
+ (att-value 'node-memory-index (ast-child 'source reference))))
+ (att-value
+ 'pmm-code:check-references
+ n
+ (pmmi-terminate (att-value 'bindings n)))
+ (att-value 'fragment-walk n)))
+ (+ (att-value 'nodes-count n) 1)))))
+
+ (ag-rule ; Function encoding PMM specialised to match the fragment the pattern node is part of.
+ pmm-code:match-fragment
+ (Node
+ (lambda (n continuation-code)
+ (fold-right
+ (lambda (context result)
+ (if (integer? context)
+ (pmmi-ensure-context-by-index result context)
+ (pmmi-ensure-context-by-name result context)))
+ (att-value 'pmm-code:match-subtree (att-value 'fragment-root n) continuation-code)
+ (att-value 'fragment-root-path n)))))
+
+ (ag-rule ; Function encoding PMM specialised to match the subtree the pattern node spans.
+ pmm-code:match-subtree
+ (Node
+ (lambda (n continuation-code)
+ (let ((store-instruction
+ (pmmi-store-node
+ (fold-right
+ (lambda (child result)
+ (pmmi-load-node
+ (if (integer? (ast-child 'context child))
+ (pmmi-ensure-child-by-index
+ (att-value 'pmm-code:match-subtree child result)
+ (ast-child 'context child))
+ (pmmi-ensure-child-by-name
+ (att-value 'pmm-code:match-subtree child result)
+ (ast-child 'context child)))
+ (att-value 'node-memory-index n)))
+ continuation-code
+ (ast-children (ast-child 'Node* n)))
+ (att-value 'node-memory-index n))))
+ (cond
+ ((att-value 'must-be-list? n)
+ (pmmi-ensure-list store-instruction))
+ ((ast-child 'type n)
+ (pmmi-ensure-subtype store-instruction (ast-child 'type n)))
+ (else store-instruction))))))
+
+ (ag-rule ; Function encoding PMM specialised to match the reference integrity of the pattern.
+ pmm-code:check-references
+ (Pattern
+ (lambda (n continuation-code)
+ (fold-left
+ (lambda (result reference)
+ (pmmi-load-node
+ (pmmi-traverse-reference
+ (pmmi-ensure-node
+ result
+ (att-value 'node-memory-index (ast-child 'target reference)))
+ (ast-child 'name reference))
+ (att-value 'node-memory-index (ast-child 'source reference))))
+ continuation-code
+ (filter
+ (lambda (reference)
+ (not (memq reference (att-value 'fragment-walk n))))
+ (ast-children (ast-child 'Ref* n)))))))
+
+ (compile-ag-specifications))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Initialisation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (when (= (specification->phase pattern-language) 1)
+ (load-pattern-language)))
diff --git a/racket/example/example.rkt b/test/example/example.rkt
similarity index 78%
rename from racket/example/example.rkt
rename to test/example/example.rkt
index d92aea5..cd7e2d2 100644
--- a/racket/example/example.rkt
+++ b/test/example/example.rkt
@@ -3,8 +3,8 @@
;;; NOTE: After changing this file you will need to M-x faceup-write-file
;;; to regenerate the .faceup test comparison file.
;;;
-;;; NOTE: You may need to disable certain features -- for example
-;;; global-paren-face-mode -- during the M-x faceup-write-file.
+;;; NOTE: You may need to disable certain features temporarily while
+;;; doing M-x faceup-write-file. See CONTRIBUTING.md for examples.
#lang racket
@@ -73,6 +73,10 @@
([ss '("a" "b" "c")])
(string-append str ss))
+(for/foldr ([str ""])
+ ([ss '("a" "b" "c")])
+ (string-append str ss))
+
;; Auto-converts word `lambda` to `λ`:
(lambda (x) #t)
@@ -170,6 +174,20 @@ asdfasdf
BAR
)
+(define x #<<Hello World
+asdfasdf
+asdfasdf
+asdfasdf
+Hello World
+ )
+
+#;(define x #<<Hi Racket
+asdfasdf
+asdfasdf
+asdfasdf
+Hi Racket
+ )
+
|identifier with spaces|
|;no comment|
@@ -217,11 +235,10 @@ BAR
(values
1/2-the-way ;should NOT be self-eval
less-than-1/2 ;should NOT be self-eval
- +inf.0
- -inf.0
- +nan.0
- #t
- #f
+ +inf.0 -inf.0 +inf.f -inf.f +inf.t -inf.t
+ +nan.0 -nan.0 +nan.f -nan.f +nan.t -nan.t
+ #t #T #true
+ #f #F #false
1
1.0
1/2
@@ -306,6 +323,23 @@ BAR
#x-f
#xf
+ ;; complex
+ -1/10e1+10/1f10i
+ #d-1/10e1+10/1f10i
+ #e-1/10e1+10/1f10i
+ #i-1/10e1+10/1f10i
+ #x-1/10e1+10/1f10i
+ #b-1/10e1+10/1f10i
+ #o-1/10e1+10/1f10i
+
+ +10.1f10-1.10e1i
+ #d+10.1f10-1.10e1i
+ #e+10.1f10-1.10e1i
+ #i+10.1f10-1.10e1i
+ #x+10.1f10-1.10e1i
+ #b+10.1f10-1.10e1i
+ #o+10.1f10-1.10e1i
+
;; exact complex, e.g. issue #445
1+2i
1/2+3/4i
@@ -315,6 +349,13 @@ BAR
2.0e1
-2.0e2
-1e-1
+
+ ;; extflonum
+ 10.1t10
+ #d10.1t10
+ #x10.1t10
+ #b10.1t10
+ #o10.1t10
))
(define/contract (valid-bucket-name? s #:keyword [dns-compliant? #t])
@@ -391,3 +432,45 @@ BAR
;; Issue 546
'C# (add1 1)
+
+;; Examples of quoted expressions that should receive
+;; font-lock-string-face, font-lock-constant-face,
+;; racket-reader-quoted-symbol-face, or none of those.
+'"string"
+'#px"regexp"
+'1234
+'#x1234
+'#t
+'+NaN.0
+'#\A
+'symbol
+`symbol
+'1symbol ;legal Racket identifier
+`1symbol
+'+
+'Noon.0
+'|foo bar|
+'|foo \| bar|
+'("string" 1 symbol) ;symbol not directly quoted
+'(a b c)
+
+;; Examples of quoted expressions that should receive
+;; font-lock-string-face, font-lock-constant-face,
+;; racket-reader-syntax-quoted-symbol-face, or none of those.
+#'"string"
+#'#px"regexp"
+#'1234
+#'#x1234
+#'#t
+#'+NaN.0
+#'#\A
+#'symbol
+#`symbol
+#'1symbol ;legal Racket identifier
+#`1symbol
+#'+
+#'Noon.0
+#'|foo bar|
+#'|foo \| bar|
+#'("string" 1 symbol) ;symbol not directly quoted
+#'(a b c)
diff --git a/test/example/example.rkt.faceup b/test/example/example.rkt.faceup
new file mode 100644
index 0000000..aa729ad
--- /dev/null
+++ b/test/example/example.rkt.faceup
@@ -0,0 +1,476 @@
+«m:;; »«x:-*- racket-indent-sequence-depth: 100; racket-indent-curly-as-sequence: t; -*-
+»
+«m:;;; »«x:NOTE: After changing this file you will need to M-x faceup-write-file
+»«m:;;; »«x:to regenerate the .faceup test comparison file.
+»«m:;;;»«x:
+»«m:;;; »«x:NOTE: You may need to disable certain features temporarily while
+»«m:;;; »«x:doing M-x faceup-write-file. See CONTRIBUTING.md for examples.
+»
+«k:#lang» «v:racket»
+
+(«k:require» xml)
+(«k:provide» valid-bucket-name?)
+
+«m:;; »«x:Various def* forms are font-locked:
+»
+(«k:define» («f:function» foo)
+ «c:#t»)
+
+(«k:define» ((«f:curried-function» x) y)
+ («b:list» x y))
+
+(«k:define» «v:a-var» «c:10»)
+
+(«b:define/contract» («f:f2» x)
+ («b:any/c» . «b:->» . «b:any»)
+ «c:#t»)
+
+(«k:define-values» («v:1st-var 2nd-var») («b:values» «c:1» «c:2»))
+
+(define-thing «v:foo») «m:;»«x:bug 276
+»
+«m:;; »«x:let: font-lock identifiers
+»
+(«k:let» ([«v:foo» «c:10»]
+ [«v:bar» «c:20»])
+ foo)
+
+(«k:let» «f:loop» ([«v:x» «c:10»])
+ («k:unless» («b:zero?» x)
+ (loop («b:sub1» x))))
+
+(«k:let*» ([«v:foo» «c:10»]
+ [«v:bar» «c:20»])
+ foo)
+
+(«k:let-values» ([(«v:a» «v:b») («b:values» «c:1» «c:2»)])
+ («b:values» a b))
+
+(«k:let*-values» ([(«v:a» «v:b») («b:values» «c:1» «c:2»)])
+ («b:values» a b))
+
+(«k:letrec-values» ([(«v:a» «v:b») («b:values» «c:1» «c:2»)])
+ («b:values» a b))
+
+(«k:let-syntax» ([«v:foo» «:racket-reader-syntax-quoted-symbol-face:#'foo»])
+ foo)
+
+(«k:letrec-syntax» ([«v:foo» «:racket-reader-syntax-quoted-symbol-face:#'foo»])
+ foo)
+
+(«k:let-syntaxes» ([(«v:foo») «:racket-reader-syntax-quoted-symbol-face:#'foo»])
+ foo)
+
+(«k:letrec-syntaxes» ([(«v:foo») «:racket-reader-syntax-quoted-symbol-face:#'foo»])
+ foo)
+
+(«k:letrec-syntaxes+values» ([(«v:foo») «:racket-reader-syntax-quoted-symbol-face:#'foo»])
+ ([(a b) («b:values» «c:1» «c:2»)])
+ foo)
+
+«m:;; »«x:for/fold is indented correctly:
+»(«k:for/fold» ([str «s:""»])
+ ([ss '(«s:"a"» «s:"b"» «s:"c"»)])
+ («b:string-append» str ss))
+
+(«k:for/foldr» ([str «s:""»])
+ ([ss '(«s:"a"» «s:"b"» «s:"c"»)])
+ («b:string-append» str ss))
+
+«m:;; »«x:Auto-converts word `lambda` to `λ`:
+»(«k:lambda» (x) «c:#t»)
+
+«m:;; »«x:Or use M-C-y to insert to insert `λ` char.
+»
+«m:;; »«x:Smart indentation for quoted lists:
+»'(«c:1» «c:2»
+ «c:3» «c:4»)
+
+«m:;; »«x:Smart indentation for vector literals:
+»#(«c:1» «c:2»
+ «c:3» «c:4»)
+
+«m:;; »«x:Smart indentation for Rackjure dict literals:
+»(«k:module» «f:x» «v:rackjure»
+ {«:racket-reader-quoted-symbol-face:'a» «c:0»
+ «:racket-reader-quoted-symbol-face:'b» «c:2»})
+
+«m:;; »«x:Silly test submodule example.
+»«m:;; »«x:Try using C-c C-f to Fold (hide) it, and C-c C-u to Unfold it.
+»(«k:module+» «f:test»
+ («k:require» rackunit)
+ (check-true «c:#t»))
+
+«m:;; »«x:Single line comment
+»
+«x:#|
+
+Multi-line
+comment
+
+|#»
+
+«m:;; »«x:Issue 362
+»
+«x:#|aaa() |#»
+
+«x:#|(hello)|#»
+
+«m:#;»«:racket--sexp-comment--default:(sexpr comment)»
+
+«m:;; »«x:Nested sexpr comments
+»
+(«b:list» «c:2»
+ «m:#;»«:racket--sexp-comment--font-lock-constant-face:2»)
+
+(«b:list» «c:1»
+ «m:#;»«:racket--sexp-comment--font-lock-constant-face:4»
+ «m:#;»«:racket--sexp-comment--default:(»«:racket--sexp-comment--font-lock-constant-face:3»«:racket--sexp-comment--default:)»)
+
+(«k:let» («m:#;»«:racket--sexp-comment--default:[»«:racket--sexp-comment--font-lock-variable-name-face:x»«:racket--sexp-comment--default: #;»«:racket--sexp-comment--font-lock-constant-face:1»«:racket--sexp-comment--default:]»
+ [«v:y» «c:2»])
+ y)
+
+«m:;; »«x:Issue 388
+»«c:1» «m:; »«x:#;
+»«c:2»
+
+«m:;; »«x:Issue 408
+»
+«s:"#;"»whatever
+«s:"#;"»(whatever)
+«s:"#;"»
+(whatever)
+
+«m:;; »«x:Issue 432
+»
+«m:#;» «m:#;» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket-reader-quoted-symbol-face:'but-not-me»
+
+«m:#;#;» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket-reader-quoted-symbol-face:'but-not-me»
+
+«m:#;» «m:#;» «m:#;» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket-reader-quoted-symbol-face:'but-not-me»
+
+«m:#;#;#;» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me» «:racket-reader-quoted-symbol-face:'but-not-me»
+
+«m:#;» «m:;; »«x:comment
+»«m:;; »«x:comment
+»«m:#;» «x:#| comment |#»
+«:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me»
+«:racket--sexp-comment--racket-reader-quoted-symbol-face:'comment-me»
+«:racket-reader-quoted-symbol-face:'but-not-me»
+
+
+(«k:define» «v:x» «:racket-here-string-face:#<<FOO
+asdfasdf
+asdfasdf
+asdfasdf
+FOO
+» )
+
+«m:#;»«:racket--sexp-comment--default:(»«:racket--sexp-comment--font-lock-keyword-face:define»«:racket--sexp-comment--default: »«:racket--sexp-comment--font-lock-variable-name-face:x»«:racket--sexp-comment--default: »«:racket--sexp-comment--racket-here-string-face:#<<BAR
+asdfasdf
+asdfasdf
+asdfasdf
+BAR
+»«:racket--sexp-comment--default: )»
+
+(«k:define» «v:x» «:racket-here-string-face:#<<Hello World
+asdfasdf
+asdfasdf
+asdfasdf
+Hello World
+» )
+
+«m:#;»«:racket--sexp-comment--default:(»«:racket--sexp-comment--font-lock-keyword-face:define»«:racket--sexp-comment--default: »«:racket--sexp-comment--font-lock-variable-name-face:x»«:racket--sexp-comment--default: »«:racket--sexp-comment--racket-here-string-face:#<<Hi Racket
+asdfasdf
+asdfasdf
+asdfasdf
+Hi Racket
+»«:racket--sexp-comment--default: )»
+
+|identifier with spaces|
+
+|;no comment|
+
+| #|no comment|# |
+
+(«k:define» («f:a-function» x «:racket-keyword-argument-face:#:keyword» [y «c:0»])
+ («k:and» («b:append» («b:car» '(«c:1» «c:2» «c:3»))))
+ («b:regexp-match?» «c:#rx»«s:"foobar"» «s:"foobar"»)
+ («b:regexp-match?» «c:#px»«s:"foobar"» «s:"foobar"»)
+ («k:define» «v:a» «c:1»)
+ («k:let» ([«v:a» «s:"foo"»]
+ [«v:b» «s:"bar"»])
+ («b:displayln» b))
+ («k:let*» ([«v:a» «s:"foo"»]
+ [«v:b» «s:"bar"»])
+ («b:displayln» b))
+ («k:let-values» ([(«v:a» «v:b») («b:values» «c:1» «c:2»)])
+ «c:#t»)
+ («k:for/list» ([x («k:in-list» («b:list» «c:1» «c:2» («b:list» «c:3» «c:4»)))])
+ («k:cond» [(«b:pair?» x) («b:car» x)]
+ [«k:else» x])))
+
+«m:;; »«x:Issue 261
+»«s:"@|widget-id|"» @|foo|
+
+«m:;; »«x:Issue 298
+»(«k:define» «v:x» («k:begin» «s:"|"» '\|))
+
+«m:;; »«x:Issue 376
+»(«k:define» «v:||» (|list|))
+
+(«k:define» («f:foo»)
+ («k:let» ([«v:x» «c:10»])
+ «c:#t»)
+
+ («k:let» ([«v:x» «c:1»]
+ [«v:y» «c:2»])
+ «c:#t»)
+
+ («k:define» «v:1/2-the-way» «c:0»)
+ («k:define» «v:less-than-1/2» «c:0»)
+
+ «m:;; »«x:Self-eval examples
+» («b:values»
+ 1/2-the-way «m:;»«x:should NOT be self-eval
+» less-than-1/2 «m:;»«x:should NOT be self-eval
+» «c:+inf.0» «c:-inf.0» «c:+inf.f» «c:-inf.f» «c:+inf.t» «c:-inf.t»
+ «c:+nan.0» «c:-nan.0» «c:+nan.f» «c:-nan.f» «c:+nan.t» «c:-nan.t»
+ «c:#t» «c:#T» «c:#true»
+ «c:#f» «c:#F» «c:#false»
+ «c:1»
+ «c:1.0»
+ «c:1/2»
+ «c:-1/2»
+ «c:#b100»
+ «c:#o123»
+ «c:#d123»
+ «c:#x7f7f»
+ «:racket-reader-quoted-symbol-face:'symbol»
+ «:racket-reader-quoted-symbol-face:'|symbol with spaces|»
+ «:racket-reader-quoted-symbol-face:'|;no comment|»
+ «:racket-reader-quoted-symbol-face:'| #|no comment|# |»
+ «:racket-reader-quoted-symbol-face:'symbol-with-no-alpha/numeric-chars»
+ «c:#\c»
+ «c:#\space»
+ «c:#\newline»
+
+ «m:;; »«x:Literal number examples
+»
+ «m:;; »«x:#b
+» «c:#b1.1»
+ «c:#b-1.1»
+ «c:#b1e1»
+ «c:#b0/1»
+ «c:#b1/1»
+ «c:#b1e-1»
+ «c:#b101»
+
+ «m:;; »«x:#d
+» «c:#d-1.23»
+ «c:#d1.123»
+ «c:#d1e3»
+ «c:#d1e-22»
+ «c:#d1/2»
+ «c:#d-1/2»
+ «c:#d1»
+ «c:#d-1»
+
+ «m:;; »«x:No # reader prefix -- same as #d
+» «c:-1.23»
+ «c:1.123»
+ «c:1e3»
+ «c:1e-22»
+ «c:1/2»
+ «c:-1/2»
+ «c:1»
+ «c:-1»
+
+ «m:;; »«x:#e
+» «c:#e-1.23»
+ «c:#e1.123»
+ «c:#e1e3»
+ «c:#e1e-22»
+ «c:#e1»
+ «c:#e-1»
+ «c:#e1/2»
+ «c:#e-1/2»
+
+ «m:;; »«x:#i always float
+» «c:#i-1.23»
+ «c:#i1.123»
+ «c:#i1e3»
+ «c:#i1e-22»
+ «c:#i1/2»
+ «c:#i-1/2»
+ «c:#i1»
+ «c:#i-1»
+
+ «m:;; »«x:#o
+» «c:#o777.777»
+ «c:#o-777.777»
+ «c:#o777e777»
+ «c:#o777e-777»
+ «c:#o3/7»
+ «c:#o-3/7»
+ «c:#o777»
+ «c:#o-777»
+
+ «m:;; »«x:#x
+» «c:#x-f.f»
+ «c:#xf.f»
+ «c:#x-f»
+ «c:#xf»
+
+ «m:;; »«x:complex
+» «c:-1/10e1+10/1f10i»
+ «c:#d-1/10e1+10/1f10i»
+ «c:#e-1/10e1+10/1f10i»
+ «c:#i-1/10e1+10/1f10i»
+ «c:#x-1/10e1+10/1f10i»
+ «c:#b-1/10e1+10/1f10i»
+ «c:#o-1/10e1+10/1f10i»
+
+ «c:+10.1f10-1.10e1i»
+ «c:#d+10.1f10-1.10e1i»
+ «c:#e+10.1f10-1.10e1i»
+ «c:#i+10.1f10-1.10e1i»
+ «c:#x+10.1f10-1.10e1i»
+ «c:#b+10.1f10-1.10e1i»
+ «c:#o+10.1f10-1.10e1i»
+
+ «m:;; »«x:exact complex, e.g. issue #445
+» «c:1+2i»
+ «c:1/2+3/4i»
+ «c:1.0+3.0e7i»
+
+ «m:;; »«x:negative exponent, e.g. issue #442
+» «c:2.0e1»
+ «c:-2.0e2»
+ «c:-1e-1»
+
+ «m:;; »«x:extflonum
+» «c:10.1t10»
+ «c:#d10.1t10»
+ «c:#x10.1t10»
+ «c:#b10.1t10»
+ «c:#o10.1t10»
+ ))
+
+(«b:define/contract» («f:valid-bucket-name?» s «:racket-keyword-argument-face:#:keyword» [dns-compliant? «c:#t»])
+ ((«b:string?») («:racket-keyword-argument-face:#:keyword» «b:boolean?») . «b:->*» . «b:boolean?»)
+ («k:cond»
+ [dns-compliant?
+ («k:and» («b:<=» «c:3» («b:string-length» s)) («b:<=» («b:string-length» s) «c:63»)
+ («b:not» («b:regexp-match» «c:#px»«s:"\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}\\.\\d{1,3}"» s))
+ («k:for/and» ([s («b:regexp-split» «c:#rx»«s:"\\."» s)])
+ («k:define» («f:valid-first-or-last?» c)
+ («k:or» («b:char-lower-case?» («b:string-ref» s «c:0»))
+ («b:char-numeric?» («b:string-ref» s «c:0»))))
+ («k:define» («f:valid-mid?» c)
+ («k:or» (valid-first-or-last? c)
+ («b:equal?» c «c:#\-»)))
+ («k:define» «v:len» («b:string-length» s))
+ («k:and» («b:<» «c:0» len)
+ (valid-first-or-last? («b:string-ref» s «c:0»))
+ (valid-first-or-last? («b:string-ref» s («b:sub1» len)))
+ («k:or» («b:<=» len «c:2»)
+ («k:for/and» ([c («b:substring» s «c:1» («b:sub1» len))])
+ (valid-mid? c))))))]
+ [«k:else»
+ («k:and» («b:<=» («b:string-length» s) «c:255»)
+ («k:for/and» ([c s])
+ («k:or» («b:char-numeric?» c)
+ («b:char-lower-case?» c)
+ («b:char-upper-case?» c)
+ («b:equal?» c «c:#\.»)
+ («b:equal?» c «c:#\-»)
+ («b:equal?» c «c:#\_»))))]))
+
+(«b:displayln» «s:"I'm running!"»)
+
+«m:;; »«x:Issue 366
+»#«s:"1"»
+#«s:"22"»
+#«s:"333"»
+
+«m:;; »«x:Issue 448
+»(fun «:racket-keyword-argument-face:#:1» #«s:"a"»)
+(fun «:racket-keyword-argument-face:#:12» #«s:"a"»)
+(fun «:racket-keyword-argument-face:#:123» #«s:"a"»)
+(fun «:racket-keyword-argument-face:#:1234» #«s:"a"»)
+(fun «:racket-keyword-argument-face:#:1» «c:#px»«s:"a"»)
+(fun «:racket-keyword-argument-face:#:12» «c:#px»«s:"a"»)
+(fun «:racket-keyword-argument-face:#:123» «c:#px»«s:"a"»)
+(fun «:racket-keyword-argument-face:#:1234» «c:#px»«s:"a"»)
+
+«m:;; »«x:Issue 463
+»(«k:or» («b:equal?» c «c:#\"») («b:equal?» c «c:#\'»))
+«c:#\"» «c:#\"»
+«c:#\"» «m:;»«x:comment
+»«c:#\'» «c:#\'»
+«c:#\'» «m:;»«x:comment
+»«c:#\nul» «c:#\null» «c:#\backspace» «c:#\tab» «c:#\vtab» «c:#\newline» «c:#\linefeed»
+«c:#\page» «c:#\return» «c:#\space» «c:#\rubout»
+«c:#\012»
+«c:#\uF»
+«c:#\uFF»
+«c:#\uFFF»
+«c:#\uFFFF»
+«c:#\Ufffff»
+«c:#\Uffffff»
+«c:#\a» «c:#\z»
+«c:#\λ»
+
+«m:;; »«x:Issue 478
+»(«x:#|blah blah blah|#» «k:begin»)
+
+«m:;; »«x:Issue 534
+»(«k:define» «v:foo‾bar» «c:42»)
+(«k:let» ([«v:foo‾bar» «c:42»]) foo‾bar)
+
+«m:;; »«x:Issue 546
+»«:racket-reader-quoted-symbol-face:'C#» («b:add1» «c:1»)
+
+«m:;; »«x:Examples of quoted expressions that should receive
+»«m:;; »«x:font-lock-string-face, font-lock-constant-face,
+»«m:;; »«x:racket-reader-quoted-symbol-face, or none of those.
+»'«s:"string"»
+'«c:#px»«s:"regexp"»
+'«c:1234»
+'«c:#x1234»
+'«c:#t»
+'«c:+NaN.0»
+'«c:#\A»
+«:racket-reader-quoted-symbol-face:'symbol»
+«:racket-reader-quoted-symbol-face:`symbol»
+«:racket-reader-quoted-symbol-face:'1symbol» «m:;»«x:legal Racket identifier
+»«:racket-reader-quoted-symbol-face:`1symbol»
+«:racket-reader-quoted-symbol-face:'+»
+«:racket-reader-quoted-symbol-face:'Noon.0»
+«:racket-reader-quoted-symbol-face:'|foo bar|»
+«:racket-reader-quoted-symbol-face:'|foo \| bar|»
+'(«s:"string"» «c:1» symbol) «m:;»«x:symbol not directly quoted
+»'(a b c)
+
+«m:;; »«x:Examples of quoted expressions that should receive
+»«m:;; »«x:font-lock-string-face, font-lock-constant-face,
+»«m:;; »«x:racket-reader-syntax-quoted-symbol-face, or none of those.
+»#'«s:"string"»
+#'«c:#px»«s:"regexp"»
+#'«c:1234»
+#'«c:#x1234»
+#'«c:#t»
+#'«c:+NaN.0»
+#'«c:#\A»
+«:racket-reader-syntax-quoted-symbol-face:#'symbol»
+«:racket-reader-syntax-quoted-symbol-face:#`symbol»
+«:racket-reader-syntax-quoted-symbol-face:#'1symbol» «m:;»«x:legal Racket identifier
+»«:racket-reader-syntax-quoted-symbol-face:#`1symbol»
+«:racket-reader-syntax-quoted-symbol-face:#'+»
+«:racket-reader-syntax-quoted-symbol-face:#'Noon.0»
+«:racket-reader-syntax-quoted-symbol-face:#'|foo bar|»
+«:racket-reader-syntax-quoted-symbol-face:#'|foo \| bar|»
+#'(«s:"string"» «c:1» symbol) «m:;»«x:symbol not directly quoted
+»#'(a b c)
diff --git a/racket/example/indent.rkt b/test/example/indent.rkt
similarity index 76%
rename from racket/example/indent.rkt
rename to test/example/indent.rkt
index 401ab10..de389d1 100644
--- a/racket/example/indent.rkt
+++ b/test/example/indent.rkt
@@ -3,8 +3,8 @@
;;; NOTE: After changing this file you will need to M-x faceup-write-file
;;; to regenerate the .faceup test comparison file.
;;;
-;;; NOTE: You may need to disable certain features -- for example
-;;; global-paren-face-mode -- during the M-x faceup-write-file.
+;;; NOTE: You may need to disable certain features temporarily while
+;;; doing M-x faceup-write-file. See CONTRIBUTING.md for examples.
;;; Quoted list
@@ -103,6 +103,12 @@
(let ([x 0])
x)
+(let/cc cc
+ cc)
+
+(let/cc cc : Any
+ cc)
+
;; indent 2
(syntax-case stx ()
@@ -207,14 +213,12 @@
;;; for/fold
-;; for/fold untyped, accum on same line
(for/fold ([a 0]
[b 0])
([x 0]
[y 0])
#t)
-;; for/fold untyped, accum on different line
(for/fold
([a 0]
[b 0])
@@ -222,15 +226,13 @@
[y 0])
#t)
-;; for/fold typed, type on same line
(for/fold : T
- ([a 0]
- [b 0])
- ([x 0]
- [y 0])
+ ([a 0]
+ [b 0])
+ ([x 0]
+ [y 0])
#t)
-;; for/fold typed, type on different line
(for/fold
: T
([a 0]
@@ -239,6 +241,24 @@
[y 0])
#t)
+;;; for/hasheq
+
+(for/hasheq ([i (in-range 1 10)])
+ (values i i))
+
+(for/hasheq
+ ([i (in-range 1 10)])
+ (values i i))
+
+(for/hasheq : (Immutable-HashTable Number Number)
+ ([i (in-range 1 10)])
+ (values i i))
+
+(for/hasheq
+ : (Immutable-HashTable Number Number)
+ ([i (in-range 1 10)])
+ (values i i))
+
;;; Bug #50
'((x
@@ -348,3 +368,66 @@
------------------------- Application
(⇓ Γ (e x) Θ v)])
+;; Issue #558
+(module+ test
+ (+
+ 1
+ #<<EOF
+()
+EOF
+ )
+ 1)
+
+(foo (bar "
+(abc)"
+ this
+ not
+ indented))
+
+;; Issue #569
+
+(for : Void
+ ([i '(1)])
+ (print i))
+
+(for : Void ([i '(1)])
+ (print i))
+
+(for* : Void
+ ([i '(1)])
+ (print i))
+
+(for* : Void ([i '(1)])
+ (print i))
+
+(let #:forall (A) ([x : A 0])
+ x)
+
+(let #:forall (A)
+ ([x : A 0])
+ x)
+
+(let loop ([n 0])
+ (displayln n)
+ (when (< n 5)
+ (loop (add1 n))))
+
+(let loop ([n : Real 1])
+ (if (< n 5)
+ (loop (add1 n))
+ n))
+
+(let loop : (Listof Natural) ([accum : (Listof Natural) null]
+ [lst : (Listof Natural) lst])
+ (cond
+ [(null? lst) accum]
+ [(even? (car lst)) (loop (cons (car lst) accum) (cdr lst))]
+ [else (loop accum (cdr lst))]))
+
+(let loop : (Listof Natural)
+ ([accum : (Listof Natural) null]
+ [lst : (Listof Natural) lst])
+ (cond
+ [(null? lst) accum]
+ [(even? (car lst)) (loop (cons (car lst) accum) (cdr lst))]
+ [else (loop accum (cdr lst))]))
diff --git a/test/example/indent.rkt.faceup b/test/example/indent.rkt.faceup
new file mode 100644
index 0000000..0bf9bb5
--- /dev/null
+++ b/test/example/indent.rkt.faceup
@@ -0,0 +1,433 @@
+«m:;; »«x:-*- racket-indent-sequence-depth: 100; racket-indent-curly-as-sequence: t; -*-
+»
+«m:;;; »«x:NOTE: After changing this file you will need to M-x faceup-write-file
+»«m:;;; »«x:to regenerate the .faceup test comparison file.
+»«m:;;;»«x:
+»«m:;;; »«x:NOTE: You may need to disable certain features temporarily while
+»«m:;;; »«x:doing M-x faceup-write-file. See CONTRIBUTING.md for examples.
+»
+«m:;;; »«x:Quoted list
+»
+'(a b
+ (a b
+ c))
+
+'((«c:1») «c:2» «c:3»
+ («c:3»)
+ «c:4» «c:5»)
+
+«m:;;; »«x:Quasiquoted list (align with head) and unquote or unquote-splicing
+»«m:;;; »«x:(use normal indent rules for the form).
+»
+`(Part ()
+ (PartNumber ()
+ ,part)
+ (ETag ()
+ ,etag))
+
+`((,(x)
+ ,y))
+
+`(Delete
+ ,@(«k:for/list» ([p («k:in-list» paths)])
+ `(«t:Object» ()
+ (Key () ,p))))
+
+«m:;;; »«x:Syntax
+»
+#'(«k:for/list» ([x xs])
+ x)
+
+#`(«k:for/list» ([x xs])
+ x)
+
+#'(«k:#%app» («k:#%app» «b:hasheq» («k:quote» a) («k:quote» «c:42»))
+ («k:quote» a))
+
+(«k:#%app» («k:#%app» «b:hasheq» («k:quote» a) («k:quote» «c:42»))
+ («k:quote» a))
+
+#'(foo («k:#%app» «b:hasheq» («k:quote» a) («k:quote» «c:42»))
+ («k:quote» a))
+
+«m:;;; »«x:Rackjure style dictionary (when racket-indent-curly-as-sequence is t).
+»
+{a b
+ c d}
+
+{a b
+ c d
+ b '(a x
+ s (x y
+ x v))}
+
+«m:;;; »«x:Vector
+»
+#(a b
+ c d)
+
+«m:;;; »«x:List with a keyword as first member (e.g. in many contracts)
+»
+(«:racket-keyword-argument-face:#:x» y
+ «:racket-keyword-argument-face:#:y» x)
+
+«m:;;; »«x:Normal function application.
+»
+(foobar x
+ y
+ z)
+
+(foobar
+ x
+ y
+ z)
+
+(«b:dict-set» a
+ b
+ c)
+
+(«b:dict-set»
+ a
+ b
+ c)
+
+(«b:call-with-values» («k:lambda» () («b:values» «c:1» «c:2»))
+ «b:+»)
+
+(«b:call-with-values»
+ («k:lambda» () («b:values» «c:1» «c:2»))
+ «b:+»)
+
+«m:;;; »«x:Forms with special indentation
+»
+(«k:let» ([«v:x» «c:0»])
+ x)
+
+(«k:let/cc» cc
+ cc)
+
+(«k:let/cc» cc «b::» «t:Any»
+ cc)
+
+«m:;; »«x:indent 2
+»
+(«k:syntax-case» stx ()
+ [(«k:_» x) #'«c:#f»]
+ [(«k:_» x y) #'«c:#t»])
+
+«m:;; »«x:indent 3
+»
+(«k:syntax-case*» stx () x
+ [(«k:_» x) #'«c:#f»]
+ [(«k:_» x y) #'«c:#t»])
+
+(«k:syntax-case*»
+ stx
+ («k:#%module-begin»
+ «k:module»
+ «k:define-values»
+ «k:define-syntaxes»
+ «k:define»
+ «b:define/contract»
+ «k:define-syntax»
+ «k:struct»
+ «k:define-struct»)
+ x
+ [(«k:_» x) #'«c:#f»]
+ [(«k:_» x y) #'«c:#t»])
+
+«m:;; »«x:begin and cond have 0 style
+»(«k:begin»
+ «c:0»
+ «c:0»)
+
+(«k:begin» «c:0»
+ «c:0»)
+
+(«k:cond» [«c:1» «c:2»]
+ [«c:3» «c:4»])
+
+(«k:cond»
+ [«c:1» «c:2»]
+ [«c:3» «c:4»])
+
+(«k:if» a
+ x
+ x)
+
+«m:;; »«x:begin*
+»
+(begin-for-foo «c:0»
+ «c:0»)
+
+(begin-for-foo
+ «c:0»
+ «c:0»)
+
+(«k:with-handlers» ([x y])
+ a b c)
+
+«m:;; »«x:def, with-, call-with- and other 'defun style
+»
+(«k:define» («f:x») x x
+ x)
+
+(«k:struct» x x
+ ())
+
+(«b:match-define» («b:list» x y)
+ («b:list» «c:1» «c:2»))
+
+(«k:with-output-to-file» path «:racket-keyword-argument-face:#:mode» «:racket-reader-quoted-symbol-face:'text» «:racket-keyword-argument-face:#:exists» «:racket-reader-quoted-symbol-face:'replace»
+ («k:λ» () («b:display» «s:"Hello, world."»)))
+
+(«k:call-with-output-file» path «:racket-keyword-argument-face:#:mode» «:racket-reader-quoted-symbol-face:'text» «:racket-keyword-argument-face:#:exists» «:racket-reader-quoted-symbol-face:'replace»
+ («k:λ» (out) («b:display» «s:"Hello, world."» out)))
+
+
+«m:;;; »«x:Special forms: When the first non-distinguished form is on the
+»«m:;;; »«x:same line as distinguished forms, disregard it for indent.
+»
+«m:;; »«x:module has indent 2
+»
+(«k:module» «c:1»
+ «c:2»
+ «c:3»
+ «c:4»
+ «c:5»)
+
+«m:;; »«x:Normal case
+»(«k:module» «c:1» «c:2»
+ «c:3»
+ «c:4»
+ «c:5»)
+
+«m:;; »«x:Weird case -- but this is how scheme-mode indents it.
+»(«k:module» «c:1» «c:2» «c:3»
+ «c:4»
+ «c:5»)
+
+«m:;; »«x:Weird case -- but this is how scheme-mode indents it.
+»(«k:module» «c:1» «c:2» «c:3» «c:4»
+ «c:5»)
+
+«m:;;; »«x:for/fold
+»
+(«k:for/fold» ([a «c:0»]
+ [b «c:0»])
+ ([x «c:0»]
+ [y «c:0»])
+ «c:#t»)
+
+(«k:for/fold»
+ ([a «c:0»]
+ [b «c:0»])
+ ([x «c:0»]
+ [y «c:0»])
+ «c:#t»)
+
+(«k:for/fold» «b::» T
+ ([a «c:0»]
+ [b «c:0»])
+ ([x «c:0»]
+ [y «c:0»])
+ «c:#t»)
+
+(«k:for/fold»
+ «b::» T
+ ([a «c:0»]
+ [b «c:0»])
+ ([x «c:0»]
+ [y «c:0»])
+ «c:#t»)
+
+«m:;;; »«x:for/hasheq
+»
+(«k:for/hasheq» ([i («k:in-range» «c:1» «c:10»)])
+ («b:values» i i))
+
+(«k:for/hasheq»
+ ([i («k:in-range» «c:1» «c:10»)])
+ («b:values» i i))
+
+(«k:for/hasheq» «b::» («t:Immutable-HashTable» «t:Number» «t:Number»)
+ ([i («k:in-range» «c:1» «c:10»)])
+ («b:values» i i))
+
+(«k:for/hasheq»
+ «b::» («t:Immutable-HashTable» «t:Number» «t:Number»)
+ ([i («k:in-range» «c:1» «c:10»)])
+ («b:values» i i))
+
+«m:;;; »«x:Bug #50
+»
+'((x
+ y) A
+ z
+ (x
+ y) A
+ z)
+
+(«b:match» args
+ [(«b:list» x) (x
+ y)] «k:...»
+ [(«b:list» x) (x y)] «k:...»
+ [(«b:list» x) (x y)] «k:...»)
+
+(«k:define-syntax» («f:fstruct» stx)
+ («b:syntax-parse» stx
+ [(«k:_» id:id (field:id «k:...»))
+ («k:with-syntax» ([(accessor «k:...»)
+ («k:for/list» ([fld («k:in-list» («b:syntax->list» #'(«b:field» «k:...»)))])
+ («b:format-id» stx «s:"~a-~a"» («b:syntax->datum» «:racket-reader-syntax-quoted-symbol-face:#'id») fld))])
+ #'(serializable-struct
+ id («b:field» «k:...») «:racket-keyword-argument-face:#:transparent»
+ «:racket-keyword-argument-face:#:property» «b:prop:procedure»
+ («k:lambda» (self . args)
+ («b:match» args
+ [(«b:list» «:racket-reader-quoted-symbol-face:'field») (accessor self)] «k:...»
+ [(«b:list» («b:list» «:racket-reader-quoted-symbol-face:'field»)) (accessor self)] «k:...»
+ [(«b:list» (list-rest «:racket-reader-quoted-symbol-face:'field» fields)) ((accessor self) fields)] «k:...»
+ [(list-rest «:racket-reader-quoted-symbol-face:'field» f args)
+ («k:struct-copy» id self
+ [«b:field» («k:apply» f (accessor self) args)])] «k:...»
+ [(list-rest («b:list» «:racket-reader-quoted-symbol-face:'field») f args) «m:;»«x:<-- THIS SEXPR IS INDENTED TOO FAR
+» («k:struct-copy» id self
+ [«b:field» («k:apply» f (accessor self) args)])] «k:...»
+ [(list-rest (list-rest «:racket-reader-quoted-symbol-face:'field» fields) args)
+ («k:struct-copy» id self
+ [«b:field» («k:apply» (accessor self) fields args)])] «k:...»))))]))
+
+«m:;; »«x:Bug #123
+»
+#hash([a . (#hash()
+ «c:0»)]
+ [b . (#hasheq()
+ «c:0»)]
+ [c . (#fx(«c:0» «c:1» «c:2»)
+ «c:0»)]
+ [d . (#fx3(«c:0» «c:1» «c:2»)
+ «c:0»)]
+ [e . (#fl(«c:0.0» «c:1.0» «c:2.0»)
+ «c:0»)]
+ [f . (#fl3(«c:0.0» «c:1.0» «c:2.0»)
+ «c:0»)]
+ [g . (#s(foo x)
+ «c:0»)]
+ [h . (#3(«c:0» «c:1» «c:2»)
+ «c:0»)])
+
+«m:;; »«x:Bug #136
+»
+«m:#;»«:racket--sexp-comment--default:(»«:racket--sexp-comment--font-lock-builtin-face:list»«:racket--sexp-comment--default: »«:racket--sexp-comment--font-lock-constant-face:1»«:racket--sexp-comment--default:
+ #;»«:racket--sexp-comment--font-lock-constant-face:2»«:racket--sexp-comment--default:
+ »«:racket--sexp-comment--font-lock-constant-face:3»«:racket--sexp-comment--default:)»
+
+(«b:list» «c:1»
+ «m:#;»«:racket--sexp-comment--default:(»«:racket--sexp-comment--font-lock-builtin-face:list»«:racket--sexp-comment--default: »«:racket--sexp-comment--font-lock-constant-face:1»«:racket--sexp-comment--default:
+ (»«:racket--sexp-comment--font-lock-keyword-face:let»«:racket--sexp-comment--default: ([»«:racket--sexp-comment--font-lock-variable-name-face:x»«:racket--sexp-comment--default: »«:racket--sexp-comment--font-lock-constant-face:2»«:racket--sexp-comment--default:]
+ #;[»«:racket--sexp-comment--font-lock-variable-name-face:y»«:racket--sexp-comment--default: »«:racket--sexp-comment--font-lock-constant-face:3»«:racket--sexp-comment--default:])
+ x)
+ »«:racket--sexp-comment--font-lock-constant-face:3»«:racket--sexp-comment--default:)»
+ «c:2»
+ «c:3»)
+
+«m:;; »«x:Bug #243
+»(«k:cond» [x y
+ z]
+ [(«b:=» a x) y
+ z])
+
+«m:;; »«x:Bug #262
+»(define-metafunction «v:λL»
+ ∪ «b::» (x «k:...») «k:...» «b:->» (x «k:...»)
+ [(∪ any_ls «k:...»)
+ ,(«k:apply» «b:append» (term (any_ls «k:...»)))])
+
+«m:;; »«x:Issue #516
+»(«k:lambda» (f [a «b::» «t:Number»]
+ [b «b::» «t:Number»]) «b::» «t:Number»
+ «c:10»)
+
+(«k:lambda» (f [a «b::» «t:Number»]
+ [b «b::» «t:Number»])
+ «b::» «t:Number»
+ «c:10»)
+
+«m:;; »«x:Issue #521
+»(define-judgment-form «v:L»
+ «:racket-keyword-argument-face:#:mode» (⇓ I I O O)
+ «:racket-keyword-argument-face:#:contract» (⇓ Γ e Δ v)
+
+ [----------- Value
+ (⇓ Γ v Γ v)]
+
+
+ [(⇓ Γ e Δ («k:λ» (y) e_*))
+ (⇓ Δ (subst e_* y x) Θ v)
+ ------------------------- Application
+ (⇓ Γ (e x) Θ v)])
+
+«m:;; »«x:Issue #558
+»(«k:module+» «f:test»
+ («b:+»
+ «c:1»
+ «:racket-here-string-face:#<<EOF
+()
+EOF
+» )
+ «c:1»)
+
+(foo (bar «s:"
+(abc)"»
+ «b:this»
+ «b:not»
+ indented))
+
+«m:;; »«x:Issue #569
+»
+(«k:for» «b::» «t:Void»
+ ([i '(«c:1»)])
+ («b:print» i))
+
+(«k:for» «b::» «t:Void» ([i '(«c:1»)])
+ («b:print» i))
+
+(«k:for*» «b::» «t:Void»
+ ([i '(«c:1»)])
+ («b:print» i))
+
+(«k:for*» «b::» «t:Void» ([i '(«c:1»)])
+ («b:print» i))
+
+(«k:let» «:racket-keyword-argument-face:#:forall» (A) ([x «b::» A «c:0»])
+ x)
+
+(«k:let» «:racket-keyword-argument-face:#:forall» (A)
+ ([x «b::» A «c:0»])
+ x)
+
+(«k:let» «f:loop» ([«v:n» «c:0»])
+ («b:displayln» n)
+ («k:when» («b:<» n «c:5»)
+ (loop («b:add1» n))))
+
+(«k:let» «f:loop» ([«v:n» «b::» «t:Real» «c:1»])
+ («k:if» («b:<» n «c:5»)
+ (loop («b:add1» n))
+ n))
+
+(«k:let» «f:loop» «b::» («t:Listof» «t:Natural») ([accum «b::» («t:Listof» «t:Natural») «b:null»]
+ [lst «b::» («t:Listof» «t:Natural») lst])
+ («k:cond»
+ [(«b:null?» lst) accum]
+ [(«b:even?» («b:car» lst)) (loop («b:cons» («b:car» lst) accum) («b:cdr» lst))]
+ [«k:else» (loop accum («b:cdr» lst))]))
+
+(«k:let» «f:loop» «b::» («t:Listof» «t:Natural»)
+ ([accum «b::» («t:Listof» «t:Natural») «b:null»]
+ [lst «b::» («t:Listof» «t:Natural») lst])
+ («k:cond»
+ [(«b:null?» lst) accum]
+ [(«b:even?» («b:car» lst)) (loop («b:cons» («b:car» lst) accum) («b:cdr» lst))]
+ [«k:else» (loop accum («b:cdr» lst))]))
diff --git a/racket-tests.el b/test/racket-tests.el
similarity index 74%
rename from racket-tests.el
rename to test/racket-tests.el
index 065e1a3..7664fe5 100644
--- a/racket-tests.el
+++ b/test/racket-tests.el
@@ -1,6 +1,6 @@
;;; racket-tests.el -*- lexical-binding: t; -*-
-;; Copyright (c) 2013-2020 by Greg Hendershott.
+;; Copyright (c) 2013-2022 by Greg Hendershott.
;; License:
;; This is free software; you can redistribute it and/or modify it
@@ -13,11 +13,14 @@
;; http://www.gnu.org/licenses/ for details.
(require 'ert)
+(require 'compile)
+(require 'cl-macs)
(require 'edmacro)
(require 'faceup)
(require 'paredit)
(require 'racket-mode)
(require 'racket-xp)
+(require 'racket-cmd)
(require 'racket-repl)
(require 'racket-edit)
(require 'racket-debug)
@@ -33,8 +36,7 @@
;;; Utility functions for "integration" testing
-(defconst ci-p (or (getenv "TRAVIS_CI")
- (getenv "CI"))
+(defconst ci-p (getenv "CI")
"Is there an environment variable saying we're running on CI?")
(defconst racket-tests/timeout (if ci-p 30 10))
@@ -74,7 +76,7 @@ supplied to it."
(racket-tests/eventually (looking-back rx (point-min))))
(defun racket-tests/see-forward-rx (rx)
- (racket-tests/eventually (looking-at rx)))
+ (racket-tests/eventually (looking-at-p rx)))
(defun racket-tests/see-back (str)
(racket-tests/see-back-rx (regexp-quote str)))
@@ -141,23 +143,44 @@ supplied to it."
(racket-tests/type&press "3)" "RET")
(should (racket-tests/see-back "3)\n2\n> "))
- ;; Smart open bracket
+ ;; 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")
+ (should (racket-tests/see-back "1\n> "))
+
+ ;; `racket-smart-open-bracket-mode'.
+ ;;
+ ;; For `paredit-mode' we test using the configuration we
+ ;; document in doc/racket-mode.org; see #647.
+ (dolist (k '("RET" "C-m" "C-j"))
+ (define-key paredit-mode-map (kbd k) nil))
(let ((typing "[cond [[values 1] #t] [else #f]]")
(expected "(cond [(values 1) #t] [else #f])\n#t\n> "))
- (racket-smart-open-bracket-mode 1)
(mapc (lambda (modes)
+ (racket-smart-open-bracket-mode -1)
(electric-pair-mode (if (car modes) 1 -1))
(if (cdr modes) (enable-paredit-mode) (disable-paredit-mode))
+ ;; Enable /after/ enabling other mode, as our doc
+ ;; string tells users to do.
+ (racket-smart-open-bracket-mode 1)
(racket-tests/type&press typing "RET")
(should (racket-tests/see-back expected)))
- (list (cons nil nil)
- (cons t nil)
- (cons nil t))))
+ (list (cons t nil) ;just `electric-pair-mode'
+ (cons nil t) ;just `paredit-mode'
+ (cons nil nil)))) ;neither/plain
;; Exit
(racket-tests/type&press "(exit)" "RET")
(should (racket-tests/see-back
- "Process *Racket REPL* connection broken by remote peer\n"))
+ "Process *Racket REPL </>* connection broken by remote peer\n"))
(kill-buffer))))
;;; Multi REPLs
@@ -216,7 +239,7 @@ c.rkt. Visit each file, racket-run, and check as expected."
(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"))
+ "Process *Racket REPL </>* connection broken by remote peer\n"))
(kill-buffer))
(kill-buffer)
(delete-file path))))
@@ -251,17 +274,15 @@ c.rkt. Visit each file, racket-run, and check as expected."
(racket-tests/should-eventually
(racket-tests/see-back (concat "\n" name "> "))))
- (racket-tests/should-eventually (get-buffer "*Racket Profile*"))
- (with-current-buffer (get-buffer "*Racket Profile*")
+ (racket-tests/should-eventually (get-buffer "*Racket Profile </>*"))
+ (with-current-buffer (get-buffer "*Racket Profile </>*")
(racket-tests/should-eventually (eq major-mode 'racket-profile-mode))
- (racket-tests/should-eventually (equal header-line-format
- " Calls MSEC Name (inferred) File"))
(kill-buffer))
(with-current-buffer repl-name
(racket-repl-exit)
(should (racket-tests/see-back
- "Process *Racket REPL* connection broken by remote peer\n"))
+ "Process *Racket REPL </>* connection broken by remote peer\n"))
(kill-buffer))
(kill-buffer)
(delete-file path)))))
@@ -283,7 +304,7 @@ c.rkt. Visit each file, racket-run, and check as expected."
(racket-tests/should-eventually
(progn (goto-char (point-min))
(racket-xp-next-definition)
- (looking-at (regexp-quote "racket/base"))))
+ (looking-at-p (regexp-quote "racket/base"))))
(racket-xp-next-definition)
(should (racket-tests/see-forward "foobar"))
(should (equal (get-text-property (point) 'help-echo) "1 bound occurrence"))
@@ -342,7 +363,7 @@ c.rkt. Visit each file, racket-run, and check as expected."
(with-racket-repl-buffer
(racket-repl-exit)
(should (racket-tests/see-back
- "Process *Racket REPL* connection broken by remote peer\n"))
+ "Process *Racket REPL </>* connection broken by remote peer\n"))
(kill-buffer))
(kill-buffer)
@@ -395,7 +416,7 @@ want to use the value of `racket-program' at run time."
(write-region code nil path nil 'no-wrote-file-message)
(find-file path)
(racket-expand-file)
- (set-buffer "*Racket Stepper*")
+ (set-buffer "*Racket Stepper </>*")
(should (eq major-mode 'racket-stepper-mode))
(should (equal header-line-format "Press RET to step. C-u RET to step all. C-h m to see help."))
(racket-tests/should-eventually
@@ -485,7 +506,7 @@ want to use the value of `racket-program' at run time."
(write-region code nil path nil 'no-wrote-file-message)
(find-file path)
(racket-expand-file 4) ;; i.e. C-u prefix
- (set-buffer "*Racket Stepper*")
+ (set-buffer "*Racket Stepper </>*")
(should (eq major-mode 'racket-stepper-mode))
(should (equal header-line-format "Press RET to step. C-u RET to step all. C-h m to see help."))
(racket-tests/should-eventually
@@ -596,7 +617,7 @@ want to use the value of `racket-program' at run time."
(goto-char (point-max)) ;after the cond expression
(racket-expand-last-sexp)
- (set-buffer "*Racket Stepper*")
+ (set-buffer "*Racket Stepper </>*")
(should (eq major-mode 'racket-stepper-mode))
(should (equal header-line-format "Press RET to step. C-u RET to step all. C-h m to see help."))
(racket-tests/should-eventually
@@ -615,29 +636,66 @@ want to use the value of `racket-program' at run time."
(racket-tests/should-eventually
(faceup-test-font-lock-buffer nil racket-tests/expand-expression-4))
+ (quit-window)
(with-racket-repl-buffer
(racket-repl-exit)
(should (racket-tests/see-back
- "Process *Racket REPL* connection broken by remote peer\n"))
+ "Process *Racket REPL </>* connection broken by remote peer\n"))
(kill-buffer))
(kill-buffer)
(delete-file path)))))
-;;; Indentation
+;;; Indentation correctness
+
+(defun racket-tests/indent-region ()
+ "Indent entire current buffer, suppressing progress-reporter messages."
+ (cl-letf (((symbol-function #'make-progress-reporter) #'ignore)
+ ((symbol-function #'progress-reporter-update) #'ignore)
+ ((symbol-function #'progress-reporter-done) #'ignore))
+ (indent-region (point-min) (point-max))))
(defun racket-tests/same-indent (file)
- (with-current-buffer (find-file (expand-file-name file
- racket-tests/here-dir))
- (indent-region (point-min) (point-max))
+ (with-current-buffer (find-file (expand-file-name file racket-tests/here-dir))
+ (racket-tests/indent-region)
(let ((ok (not (buffer-modified-p))))
(revert-buffer t t t) ;revert in case running ERT interactively
ok)))
-(ert-deftest racket-tests/indent-rkt ()
+(ert-deftest racket-tests/indent-same ()
"Indentation of example/*.rkt shouldn't change."
- (should (racket-tests/same-indent "racket/example/example.rkt"))
- (should (racket-tests/same-indent "racket/example/indent.rkt")))
+ (should (racket-tests/same-indent "example/example.rkt"))
+ (should (racket-tests/same-indent "example/indent.rkt")))
+
+;;; Indentation speed
+
+;; To measure the performance of `racket-indent-line', these tests
+;; call `indent-region' on some examples of unusually large files.
+;; Re-indenting huge files isn't a priority use case for Racket Mode.
+;; We don't even bother to supply an `indent-region-function'. Indeed
+;; these tests rely on the fact that `indent-region' will therefore
+;; call `racket-indent-line' for every one of the thousands of lines
+;; in these files. The huge example files are just a convenient way to
+;; get a large, varied amount of test data.
+
+(defun racket-tests/indent-time (file)
+ (with-current-buffer (find-file (expand-file-name file racket-tests/here-dir))
+ (racket-mode)
+ (let* ((start (float-time))
+ (_ (racket-tests/indent-region))
+ (finish (float-time))
+ (dur (- finish start)))
+ (message "indent %s took %s seconds" file dur)
+ (revert-buffer t t t)
+ dur)))
+
+(ert-deftest racket-tests/indent-speed-1 ()
+ (should (or (< (racket-tests/indent-time "example/class-internal.rkt") 10)
+ ci-p)))
+
+(ert-deftest racket-tests/indent-speed-2 ()
+ (should (or (< (racket-tests/indent-time "example/core.scm") 10)
+ ci-p)))
;;; Font-lock
@@ -646,15 +704,14 @@ want to use the value of `racket-program' at run time."
FILE is interpreted as relative to this source directory."
(let ((font-lock-maximum-decoration t))
(faceup-test-font-lock-file 'racket-mode
- (expand-file-name file
- racket-tests/here-dir))))
+ (expand-file-name file racket-tests/here-dir))))
(faceup-defexplainer racket-tests/same-faceup)
(ert-deftest racket-tests/font-lock ()
"Font-lock of example/*.rkt shouldn't change."
- (should (racket-tests/same-faceup "racket/example/indent.rkt"))
- (should (racket-tests/same-faceup "racket/example/example.rkt")))
+ (should (racket-tests/same-faceup "example/indent.rkt"))
+ (should (racket-tests/same-faceup "example/example.rkt")))
;;; fill-paragraph comment issue 437
@@ -670,6 +727,79 @@ 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)
+ (with-temp-buffer
+ (let* ((num-top-level-sexprs 3000)
+ (orig (mapcar (lambda (_)
+ (mapcar (lambda (_)
+ (if (zerop (random 2))
+ (random 1000)
+ (make-string (+ 5 (random 10))
+ (+ ?a (random 26)))))
+ (make-list (+ 10 (random 90)) nil)))
+ (make-list num-top-level-sexprs nil)))
+ (orig-as-str (apply #'concat
+ (mapcar (lambda (s) (concat s "\n"))
+ (mapcar #'prin1-to-string
+ orig))))
+ (results nil))
+ ;; Simulate the process filter getting the text in arbitrary
+ ;; chunks, inserting into the buffer, and calling
+ ;; `racket--cmd-read' to read any available complete top-level
+ ;; sexprs.
+ (cl-flet ((add/read (str)
+ (goto-char (point-max))
+ (insert str)
+ (racket--cmd-read (lambda (v) (push v results)))))
+ (while (< 0 (length orig-as-str))
+ (let ((len (max 1 (random (length orig-as-str)))))
+ (add/read (substring orig-as-str 0 len))
+ (setq orig-as-str (substring orig-as-str len))))
+ (setq results (reverse results))
+ (should (equal orig results)))))))
+
(provide 'racket-tests)
;;; racket-tests.el ends here
diff --git a/racket/test/find-examples.rkt b/test/racket/find-examples.rkt
similarity index 100%
rename from racket/test/find-examples.rkt
rename to test/racket/find-examples.rkt
diff --git a/racket/test/find.rkt b/test/racket/find.rkt
similarity index 97%
rename from racket/test/find.rkt
rename to test/racket/find.rkt
index 9059c28..2f87082 100644
--- a/racket/test/find.rkt
+++ b/test/racket/find.rkt
@@ -6,8 +6,8 @@
racket/runtime-path
rackunit
syntax/modread
- "../find.rkt"
- "../syntax.rkt"
+ "../../racket/find.rkt"
+ "../../racket/syntax.rkt"
"find-examples.rkt")
(define ((path-ends-in? . xs) ps)
@@ -16,7 +16,7 @@
(define (not-0 v) (not (= 0 v)))
(define (not-1 v) (not (= 1 v)))
-(define-runtime-path parent-dir "..")
+(define-runtime-path parent-dir "../../racket/")
(define (test how)
(check-equal? (find-definition how "display")
More details
Historical runs
- debhelper-pattern-not-found: debhelper (installdocs: error) expansion failed for '*.md' (directories: ['.', 'debian/tmp'])
- unsatisfied-apt-dependencies: Unsatisfied APT dependencies: perlapi-5.34.0:amd64
- worker-failure: ImportError: cannot import name 'MissingChangelogError' from 'breezy.plugins.debian.vcs_up_to_date' (/usr/local/lib/python3.10/dist-packages/breezy/plugins/debian/vcs_up_to_date.py)
- run-disappeared: Jenkins job https://jenkins.debian.net/job/janitor-worker/759903/ has disappeared
- result-push-failed: Failed to push result branch: Connection closed: Connection closed early The remote server unexpectedly closed the connection.
- result-push-failed: Failed to push result branch: Connection closed: Connection closed early The remote server unexpectedly closed the connection.
- success: Merged new upstream version 20220514git0
- build-failed-stage-explain-bd-uninstallable: build failed stage explain-bd-uninstallable