├── .dir-locals.el ├── .elpaignore ├── .github ├── FUNDING.yml ├── ISSUE_TEMPLATE │ ├── bug-report.md │ ├── feature-request.md │ └── question.md └── workflows │ └── test.yml ├── .gitignore ├── CONTRIBUTING.org ├── LICENSE ├── Makefile ├── README.org ├── THANKS.org ├── doc ├── Makefile ├── README.org ├── arch-pict.rkt ├── generate.el ├── racket-mode.css ├── racket-mode.org └── racket-mode.texi ├── racket-back-end.el ├── racket-browse-url.el ├── racket-bug-report.el ├── racket-cmd.el ├── racket-collection.el ├── racket-common.el ├── racket-complete.el ├── racket-custom.el ├── racket-debug.el ├── racket-describe.el ├── racket-doc.el ├── racket-edit.el ├── racket-eldoc.el ├── racket-font-lock.el ├── racket-hash-lang.el ├── racket-imenu.el ├── racket-indent.el ├── racket-input.el ├── racket-keywords-and-builtins.el ├── racket-lisp-mode.el ├── racket-logger.el ├── racket-mode.el ├── racket-package.el ├── racket-parens.el ├── racket-ppss.el ├── racket-profile.el ├── racket-repl-buffer-name.el ├── racket-repl.el ├── racket-scribble-anchor.el ├── racket-scribble.el ├── racket-shell.el ├── racket-show.el ├── racket-smart-open.el ├── racket-stepper.el ├── racket-util.el ├── racket-visit.el ├── racket-wsl.el ├── racket-xp-complete.el ├── racket-xp.el ├── racket ├── command-server.rkt ├── commands │ ├── check-syntax.rkt │ ├── describe.rkt │ ├── find-module.rkt │ ├── help.rkt │ ├── macro.rkt │ ├── module-names.rkt │ └── requires.rkt ├── debug-annotator.rkt ├── debug.rkt ├── define-fallbacks.rkt ├── elisp.rkt ├── error.rkt ├── find-module-path-completions.rkt ├── find.rkt ├── gui.rkt ├── hash-lang-bridge.rkt ├── hash-lang.rkt ├── identifier.rkt ├── image.rkt ├── imports.rkt ├── instrument.rkt ├── interaction.rkt ├── keywords.rkt ├── lang-info.rkt ├── lib-pkg.rkt ├── logger.rkt ├── main.rkt ├── online-check-syntax.rkt ├── package.rkt ├── print.rkt ├── repl-output.rkt ├── repl-session.rkt ├── repl.rkt ├── safe-dynamic-require.rkt ├── scribble.rkt ├── stack-checkpoint.rkt ├── syntax.rkt ├── text-lines.rkt ├── util.rkt └── xref.rkt └── test ├── example ├── .gitattributes ├── class-internal.rkt ├── core.scm ├── example.rkt ├── example.rkt.faceup ├── indent.rkt ├── indent.rkt.faceup └── requires.rkt ├── racket-tests.el └── racket ├── find-examples.rkt ├── find.rkt └── hash-lang-test.rkt /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((nil 2 | (indent-tabs-mode . nil) 3 | (require-final-newline . t) 4 | (show-trailing-whitespace . t)) 5 | (makefile-mode 6 | (indent-tabs-mode . t)) 7 | (prog-mode 8 | (comment-column . 40) 9 | (fill-column . 70)) 10 | (racket-mode 11 | ;; Better indentation for quoted xexprs and for at-exprs: 12 | (racket-indent-sequence-depth . 3) 13 | (racket-indent-curly-as-sequence . t))) 14 | -------------------------------------------------------------------------------- /.elpaignore: -------------------------------------------------------------------------------- 1 | .dir-locals.el 2 | .elpaignore 3 | .git 4 | .github 5 | .gitignore 6 | Makefile 7 | racket/compiled 8 | racket/commands/compiled 9 | test 10 | doc/Makefile 11 | doc/README.org 12 | doc/arch-pict.rkt 13 | doc/generate.el 14 | doc/*.css 15 | doc/*.html 16 | doc/*.info 17 | doc/*.org 18 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: greghendershott 2 | custom: https://www.paypal.me/greghendershott 3 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug-report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug Report 3 | about: Report a problem with existing features 4 | labels: bug 5 | --- 6 | 7 | To help me help you, please: 8 | 9 | 1. Open any racket-mode or racket-repl-mode buffer. 10 | 11 | 2. M-x `racket-bug-report` ENTER. 12 | 13 | 3. Copy and paste that, here. 14 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature-request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature Request 3 | about: Suggest an idea for a new feature 4 | labels: enhancement 5 | --- 6 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/question.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Question 3 | about: Ask a question about how to use Racket Mode 4 | labels: question 5 | --- 6 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | pull_request: 6 | schedule: 7 | - cron: '0 0 * * 2' # 00:00 every Tuesday 8 | 9 | jobs: 10 | ubuntu: 11 | runs-on: ubuntu-latest 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | emacs_version: 16 | - '25.1' # our minimum supported version 17 | - '26.3' 18 | - '30.1' # most recent release 19 | racket_version: 20 | - '7.8' # our minimum supported version 21 | - 'stable' # most recent release 22 | # Also include bleeding edge snapshots of both Emacs and 23 | # Racket. Note that "allow_failure: true" doesn't seem to 24 | # actually work yet on GitHub Actions like it does on Travis 25 | # CI: If this fails it will say the overall job failed. :( 26 | # Meanwhile in the GitHub protected branch settings we make 27 | # this one NOT a required status check -- which is some but 28 | # not all of the behavior we miss from Travis CI. 29 | include: 30 | - emacs_version: 'snapshot' 31 | racket_version: 'current' 32 | allow_failure: true 33 | name: Ubuntu Emacs:${{ matrix.emacs_version }} Racket:${{ matrix.racket_version }} 34 | steps: 35 | - name: Checkout 36 | uses: actions/checkout@master 37 | - name: Install Emacs 38 | uses: purcell/setup-emacs@master 39 | with: 40 | version: ${{ matrix.emacs_version }} 41 | - name: Install Racket 42 | uses: Bogdanp/setup-racket@v1.11 43 | with: 44 | architecture: 'x64' 45 | distribution: 'full' 46 | version: ${{ matrix.racket_version }} 47 | - name: Show versions 48 | run: make show-versions 49 | - name: Install Emacs Packages 50 | run: make deps 51 | - name: Compile Emacs Lisp 52 | run: make compile 53 | - name: Run Emacs Lisp Tests 54 | run: make test-elisp 55 | - name: Run Racket Tests 56 | run: xvfb-run make test-racket 57 | 58 | # The motivation for this job is to see if tests are likely to pass 59 | # when run on headless servers such as Debian `buildd` with the 60 | # Minimal Racket distriubtion (or equivalent), plus manually 61 | # installing the Racket packages recommended in our documentation. 62 | # The tests themselves should detect the absence of a display or a 63 | # missing Racket package and skip. See *** in comments below. 64 | minimal: 65 | runs-on: ubuntu-latest 66 | strategy: 67 | fail-fast: false 68 | matrix: 69 | emacs_version: 70 | - '30.1' # most recent release 71 | racket_version: 72 | - 'stable' # most recent release 73 | name: Minimal Racket 74 | steps: 75 | - name: Checkout 76 | uses: actions/checkout@master 77 | - name: Install Emacs 78 | uses: purcell/setup-emacs@master 79 | with: 80 | version: ${{ matrix.emacs_version }} 81 | - name: Install Racket 82 | uses: Bogdanp/setup-racket@v1.11 83 | with: 84 | architecture: 'x64' 85 | distribution: 'minimal' # *** NOT 'full' 86 | version: ${{ matrix.racket_version }} 87 | - name: Install some non-Minimal Racket packages # *** 88 | run: make minimal-racket-deps 89 | - name: Show versions 90 | run: make show-versions 91 | - name: Install Emacs Packages 92 | run: make deps 93 | - name: Compile Emacs Lisp 94 | run: make compile 95 | - name: Run Emacs Lisp Tests 96 | run: make test-elisp 97 | - name: Run Racket Tests 98 | run: make test-racket # *** do NOT use xvfb-run 99 | 100 | windows: 101 | runs-on: windows-latest 102 | strategy: 103 | fail-fast: false 104 | matrix: 105 | emacs_version: 106 | - '30.1' # most recent release 107 | racket_version: 108 | - 'stable' # most recent release 109 | name: Windows Emacs:${{ matrix.emacs_version }} Racket:${{ matrix.racket_version }} 110 | steps: 111 | - name: Checkout 112 | uses: actions/checkout@master 113 | - name: Install Emacs 114 | uses: jcs090218/setup-emacs-windows@master 115 | with: 116 | version: ${{ matrix.emacs_version }} 117 | - name: Install Racket 118 | uses: Bogdanp/setup-racket@v1.11 119 | with: 120 | architecture: 'x64' 121 | distribution: 'full' 122 | version: ${{ matrix.racket_version }} 123 | - name: Install Emacs Packages 124 | run: make deps 125 | - name: Compile Elisp 126 | run: make compile 127 | - name: Run Emacs Lisp Tests 128 | run: make test-elisp 129 | - name: Run Racket Tests 130 | run: make test-racket 131 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | compiled/ 3 | *.elc 4 | doc/*.texi~ 5 | doc/*.info 6 | doc/reference.org 7 | doc/racket-mode.html 8 | doc/*.png 9 | doc/*.svg 10 | # ELPA-generated files 11 | /racket-mode-autoloads.el 12 | /racket-mode-pkg.el 13 | -------------------------------------------------------------------------------- /CONTRIBUTING.org: -------------------------------------------------------------------------------- 1 | * Reporting bugs 2 | 3 | If you're going to report a bug --- thank you! 4 | 5 | Please use =M-x racket-bug-report= to generate a buffer with 6 | information that will help to reproduce and understand the bug: 7 | 8 | - Emacs version. 9 | - Value of important Racket Mode variables. 10 | - Minor modes that are active. 11 | 12 | Please copy that and paste in your bug report. 13 | 14 | * Making pull requests 15 | 16 | If you'd like to make a pull request --- thank you! 17 | 18 | Here is some information to help you. 19 | 20 | ** Package dependencies 21 | 22 | For end users, Racket Mode currently has zero dependencies on other 23 | packages --- in =racket-mode.el= =Package-Requires:= is just: 24 | 25 | #+BEGIN_SRC elisp 26 | ;; Package-Requires: ((emacs "25.1")) 27 | #+END_SRC 28 | 29 | For hacking on Racket Mode and to run tests, a couple packages are 30 | required. To install them: =make deps=. 31 | 32 | The recent trend has been for Racket Mode to depend on fewer packages, 33 | not more. For example =dash.el= and =s.el= were dropped in favor of 34 | directly using the built-in Emacs functions wrapped by those packages. 35 | 36 | Having said that, if your PR proposes adding a dependency on a new 37 | package that you think is worthwhile, please make sure your PR updates 38 | both: 39 | 40 | 1. the =Package-Requires:= line in =racket-mode.el= 41 | 2. the =deps= target in =Makefile= 42 | 43 | ** Contributing code you did not write yourself 44 | 45 | It is fine to propose adding code that you copied from elsewhere, 46 | provided you say where ("provenance") and the license (e.g. "GPL", 47 | "MIT", etc.). Including a URL in a source code comment is ideal. 48 | 49 | As a GPL project, we can use code from most other types of licenses, 50 | but we need to know exactly which license, if any. 51 | 52 | Also we prefer to give credit ("attribution"), and in fact some 53 | licenses require this. 54 | 55 | **Important**: Because it is impossible to know the provenance/license 56 | of code generated by an LLM or "AI" (such as GitHub Copilot) we cannot 57 | accept such code. 58 | 59 | ** Pointing Emacs to your Git clone 60 | 61 | After installing dependencies you should just need to add the path to 62 | your local clone of Racket Mode to =load-path= and require it: 63 | 64 | #+BEGIN_SRC elisp 65 | (add-to-list 'load-path "/path/to/the/git-clone/dir") 66 | (require 'racket-mode) 67 | #+END_SRC 68 | 69 | If you use =use-package=, you can simply replace 70 | 71 | #+BEGIN_SRC elisp 72 | (use-package racket-mode 73 | :ensure t) 74 | #+END_SRC 75 | 76 | with 77 | 78 | #+BEGIN_SRC elisp 79 | (use-package racket-mode 80 | :load-path "/path/to/the/git-clone/dir") 81 | #+END_SRC 82 | 83 | If you have previously been using Racket Mode as a package installed 84 | from MELPA, you might want to remove that, at least for the duration 85 | of your hacking: 86 | 87 | - =M-x package-delete= and enter =racket-mode=. 88 | - Restart Emacs. 89 | 90 | ** Generating reference documentation 91 | 92 | We generate reference documentation from doc strings for commands, 93 | variables, and faces. 94 | 95 | - If you add a brand-new command =defun=, =defcustom=, or =defface=, 96 | please also add it to the appropriate list in =doc/generate.el=. 97 | 98 | - Whenever you edit a doc string for a command =defun=, =defcustom=, 99 | or =defface=, please =cd doc && make clean docs=, and commit the 100 | updated files. 101 | 102 | ** Tests 103 | 104 | Currently tests are on the light side. More are welcome. 105 | 106 | Please do run =make test= locally to ensure your changes pass the 107 | existing tests. 108 | 109 | GitHub Actions also does =make test= automatically on your pull 110 | request. 111 | 112 | GitHub branch protection is enabled for the main branch --- merges 113 | are blocked until tests pass. 114 | 115 | *** Example files for indentation and font-lock 116 | 117 | Some Racket Mode tests apply indentation and font-lock to the 118 | =test/example/example.rkt= and =test/example/indent.rkt= files and 119 | compare the result to corresponding =.faceup= files (generated by the 120 | =faceup= package). 121 | 122 | As a result, if your PR intentionally modifies indentation or 123 | font-lock, you may need to regenerate the =.faceup= files. To do so: 124 | 125 | 1. Disable any personal Emacs features that affect font-lock or 126 | indentation. For example you may need to =M-x global-paren-mode= 127 | and =M-x prettify-symbols-mode= to disable those. 128 | 129 | 2. For each =.rkt= file: 130 | 131 | - Visit the =.rkt= file. 132 | 133 | - =M-x mark-buffer= and =M-x indent-region=. 134 | 135 | - =M-x save-buffer= to save the =.rkt= file. 136 | 137 | - =M-x faceup-write-file= and answer, yes, replace the existing 138 | =.faceup= file. 139 | 140 | 3. Re-enable any personal features you disabled in step 1. 141 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY : help show-versions clean compile deps minimal-racket-deps test test-elisp test-racket test-racket-submod test-racket-plain test-racket-slow 2 | 3 | help: 4 | @echo "Targets: show-versions, clean, compile, deps, test, test-elisp, test-racket, test-slow" 5 | 6 | # Allow running with an emacs or racket executable other than the 7 | # default on PATH. e.g. `EMACS=/path/to/emacs make`. 8 | EMACS ?= emacs 9 | RACKET ?= racket 10 | 11 | show-versions: 12 | @echo `which $(RACKET)` 13 | @$(RACKET) --version 14 | @echo `which $(EMACS)` 15 | @$(EMACS) --version 16 | 17 | test: test-racket test-elisp 18 | 19 | ###################################################################### 20 | # Emacs 21 | 22 | batch-emacs := \ 23 | $(EMACS) --batch -Q -L . \ 24 | --eval '(require (quote package))' \ 25 | --eval '(package-initialize)' 26 | 27 | byte-compile := \ 28 | $(batch-emacs) \ 29 | -l bytecomp \ 30 | --eval '(setq byte-compile-warnings (quote (not obsolete)))' \ 31 | --eval '(setq byte-compile-error-on-warn t)' \ 32 | -f batch-byte-compile 33 | 34 | %.elc : %.el 35 | $(byte-compile) $< 36 | 37 | # Build an .elc file for every .el file in the top dir. 38 | elc-files := $(patsubst %.el,%.elc,$(wildcard *.el)) 39 | 40 | clean: 41 | -rm $(elc-files) 2> /dev/null 42 | 43 | compile: check-declares $(elc-files) 44 | 45 | check-declares: 46 | $(batch-emacs) \ 47 | -l check-declare \ 48 | --eval '(unless (eq system-type (quote windows-nt)) (when (check-declare-directory default-directory) (kill-emacs 1)))' 49 | 50 | # Install Emacs packages we depend on for development and/or testing. 51 | # Intended to be run once per machine by developers, as well as by CI. 52 | # (Normal users get a subset of these deps automatically as a result 53 | # of our Package-Requires in racket-mode.el.) 54 | melpa-url := https://melpa.org/packages/ 55 | deps: 56 | $(batch-emacs) \ 57 | --eval '(add-to-list (quote package-archives) (cons "melpa" "$(melpa-url)"))' \ 58 | --eval '(unless (fboundp (quote lisp-data-mode)) (defalias (quote lisp-data-mode) (quote emacs-lisp-mode)))' \ 59 | --eval '(package-refresh-contents)' \ 60 | --eval '(package-install (quote compat))' \ 61 | --eval '(package-install (quote faceup))' \ 62 | --eval '(package-install (quote paredit))' 63 | 64 | test-elisp: 65 | $(batch-emacs) \ 66 | -l ert \ 67 | -l test/racket-tests.el \ 68 | --eval '(setq racket-program "$(RACKET)")' \ 69 | -f ert-run-tests-batch-and-exit 70 | 71 | ###################################################################### 72 | # Racket 73 | 74 | # This target is for a CI configuration using the Minimal Racket 75 | # distribution. In that case we need some additional Racket packages 76 | # from the main distribution -- as described in our end user docs at 77 | # . 78 | minimal-racket-deps: 79 | $(RACKET) -l raco pkg install --auto \ 80 | data-lib errortrace-lib macro-debugger-text-lib rackunit-lib \ 81 | racket-index scribble-lib drracket-tool-text-lib 82 | 83 | test-racket: test-racket-submod test-racket-plain 84 | 85 | # Most tests exist inside `test` submodules of ordinary source files. 86 | # 87 | # Exclude racket/hash-lang.rkt because it fails to eval on older 88 | # Rackets. Normally we only dynamic-require it. Furthermore its tests 89 | # are in ./test/racket/hash-lang-test.rkt. 90 | test-racket-submod: 91 | $(RACKET) -l raco test --submodule test --no-run-if-absent \ 92 | $(filter-out ./racket/hash-lang.rkt, $(wildcard ./racket/*.rkt)) \ 93 | $(wildcard ./racket/commands/*.rkt) 94 | 95 | # Plus we do have some files in a special directory that consist of 96 | # tests in the file's root module. 97 | test-racket-plain: 98 | $(RACKET) -l raco test ./test/racket/ 99 | 100 | # Some very slow tests segregated in `slow-test` submodules so that 101 | # they're not run by default. 102 | test-racket-slow: 103 | $(RACKET) -l raco test --submodule slow-test ./racket/imports.rkt 104 | $(RACKET) -l raco test --submodule slow-test ./racket/commands/check-syntax.rkt 105 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Racket mode for GNU Emacs 2 | 3 | [[https://github.com/greghendershott/racket-mode/actions][https://github.com/greghendershott/racket-mode/workflows/CI/badge.svg]] 4 | [[https://melpa.org/#/racket-mode][https://melpa.org/packages/racket-mode-badge.svg]] 5 | [[https://elpa.nongnu.org/nongnu/racket-mode.html][https://elpa.nongnu.org/nongnu/racket-mode.svg]] 6 | [[https://www.racket-mode.com/][https://img.shields.io/badge/Docs-Documentation-blue.svg]] 7 | 8 | A variety of Emacs major and minor modes for [[https://www.racket-lang.org/][Racket]]: edit, REPL, 9 | check-syntax, debug, profile, logging, and more. The edit/run 10 | experience is similar to [[https://docs.racket-lang.org/drracket/][DrRacket]]. 11 | 12 | Compatible with *Emacs 25.1+* and *Racket 7.8+*. 13 | 14 | ** Documentation 15 | 16 | See the [[https://www.racket-mode.com/][Guide and Reference]]. 17 | 18 | ** Contributing 19 | 20 | Pull requests are welcome; please see [[https://github.com/greghendershott/racket-mode/blob/master/CONTRIBUTING.org][CONTRIBUTING.org]]. 21 | 22 | ** Acknowledgments 23 | 24 | [[https://github.com/greghendershott/racket-mode/blob/master/THANKS.org][THANKS.org]]. 25 | 26 | ** Alternatives 27 | 28 | - Emacs' built-in `scheme-mode` major mode plus the minor modes [[https://www.neilvandyke.org/quack/][Quack]] 29 | and/or [[https://www.nongnu.org/geiser/][Geiser]]. 30 | -------------------------------------------------------------------------------- /THANKS.org: -------------------------------------------------------------------------------- 1 | * Contributors 2 | 3 | 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]]. 4 | 5 | ** Acknowledgements 6 | 7 | - The existing Emacs Scheme mode and Inferior Scheme mode. 8 | 9 | - The source code for for [[http://www.neilvandyke.org/quack/][Quack]] by Neil Van Dyke provided a model for 10 | many of the scheme-indent-function settings, smart paren closing, 11 | and pretty lambda. 12 | 13 | - The source code for [[http://www.nongnu.org/geiser/][Geiser]] by Jose A. Ortega Ruiz helped me 14 | understand how to support completions and especially company-mode. 15 | In addition, I was able to make heavy use of a pull request to 16 | display images in the REPL. 17 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: doc docs images clean deploy 2 | 3 | doc: images racket-mode.info racket-mode.html 4 | 5 | docs: doc 6 | 7 | clean: 8 | -rm scenario*.png 9 | -rm scenario*.svg 10 | -rm reference.org 11 | -rm racket-mode.info 12 | -rm racket-mode.html 13 | 14 | images: 15 | racket arch-pict.rkt 16 | 17 | reference.org: generate.el 18 | emacs --batch -Q --eval '(progn (add-to-list (quote load-path) "${PWD}/../") (package-initialize))' -l generate.el --funcall 'racket-generate-reference.org' 19 | 20 | racket-mode.texi: racket-mode.org reference.org 21 | 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 22 | 23 | racket-mode.info: racket-mode.texi 24 | makeinfo --no-split $< -o $@ 25 | 26 | racket-mode.html: racket-mode.texi 27 | makeinfo --html --no-split --no-headers --no-number-sections --set-customization-variable DOCTYPE="" --css-ref='racket-mode.css' $< 28 | 29 | 30 | ###################################################################### 31 | # S3 bucket deploy 32 | 33 | aws := aws --profile greg 34 | dest := s3://www.racket-mode.com 35 | cfid := E1OG6O4MCHIO1Q 36 | 37 | .PHONY: deploy 38 | 39 | deploy: racket-mode.html racket-mode.css images 40 | $(aws) s3 cp racket-mode.html $(dest)/index.html 41 | $(aws) s3 cp racket-mode.css $(dest)/racket-mode.css 42 | $(aws) s3 cp scenario-0.svg $(dest)/scenario-0.svg 43 | $(aws) s3 cp scenario-1.svg $(dest)/scenario-1.svg 44 | $(aws) s3 cp scenario-2.svg $(dest)/scenario-2.svg 45 | $(aws) s3 cp scenario-3.svg $(dest)/scenario-3.svg 46 | $(aws) s3 cp scenario-4.svg $(dest)/scenario-4.svg 47 | $(aws) cloudfront create-invalidation --distribution-id $(cfid) --paths "/*" > /dev/null 48 | -------------------------------------------------------------------------------- /doc/README.org: -------------------------------------------------------------------------------- 1 | * Documentation 2 | 3 | #+BEGIN_SRC picture 4 | 5 | +-----------------+ 6 | | racket-mode.org | +---------------+ --------------- 7 | | #!INCLUDE: |--<--| reference.org |--<--/ generate.el /---<--{doc strings} 8 | +-----------------+ +---------------+ --------------- 9 | | 10 | | +------------------+ +------------------+ 11 | +--->---| racket-mode.texi |--->---| racket-mode.info | 12 | | +------------------+ +------------------+ 13 | | 14 | | +------------------+ 15 | +--->---| racket-mode.html | 16 | +------------------+ 17 | 18 | #+END_SRC 19 | 20 | Note that for Info documentation, we actually commit just the 21 | ~racket-mode.texi~ file so that MELPA can deliver it. We let 22 | ~package-install~ generate the ~.info~ file. (At least, I /think/ 23 | that's how it's supposed to work.) 24 | 25 | Tip: As a developer, to review the ~racket-mode.info~ locally, just 26 | use a prefix with the info command: ~C-u C-h i~. 27 | -------------------------------------------------------------------------------- /doc/arch-pict.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require pict 7 | pict/color 8 | (only-in racket/draw make-color)) 9 | 10 | (define pipe-color "blue") 11 | (define ssh-color "purple") 12 | 13 | (define host-color (make-color 0 0 0 0.0)) 14 | (define front-end-color (make-color #xF0 #xF7 #xF0 1.0)) 15 | (define back-end-color (make-color #xF7 #xFF #xF7 1.0)) 16 | 17 | (define (background #:color color p) 18 | (cc-superimpose (filled-rectangle #:color color 19 | (pict-width p) 20 | (pict-height p)) 21 | p)) 22 | 23 | ;; Simplify usage of raw `frame` and `inset`. Nicer to supply as 24 | ;; keyword arg prefixes rather than suffixes. Also handle common case 25 | ;; of (inset (frame (inset __))). Also add background color. 26 | (define (box #:inset [in #f] 27 | #:outset [out #f] 28 | #:color [color #f] 29 | #:background [bg #f] 30 | #:segment [segment #f] 31 | #:width [width #f] 32 | p) 33 | (let* ([p (if in (inset p in) p)] 34 | [p (if bg (background #:color bg p) p)] 35 | [p (frame #:color color 36 | #:segment segment 37 | #:line-width width 38 | p)] 39 | [p (if out (inset p out) p)]) 40 | p)) 41 | 42 | (define (front-end) 43 | (box 44 | #:inset 5 45 | #:outset 5 46 | #:background front-end-color 47 | (vl-append 48 | (text "Emacs front end" '(bold)) 49 | (hc-append 50 | (text "Command requests/responses and notifications via ") 51 | (colorize (text "pipe" '(bold)) pipe-color) 52 | (text " or ") 53 | (colorize (text "ssh" '(bold)) ssh-color) 54 | (text "."))))) 55 | 56 | (define (backend path) 57 | (define i/o-color (if (regexp-match? #rx"^/[^:]+:" path) ssh-color pipe-color)) 58 | (box 59 | #:inset 5 60 | #:color (light "black") 61 | #:background back-end-color 62 | (vc-append 63 | 5 64 | (text "Racket back end process" '(bold)) 65 | (box #:color (light "black") #:background (light "black") 66 | #:inset 2 #:outset 6 67 | (colorize (text path '(bold . modern)) "white")) 68 | (ht-append 69 | 10 70 | (colorize 71 | (box #:inset 5 (text "Commands")) 72 | i/o-color) 73 | (vl-append 74 | 4 75 | (colorize (box #:inset 2 (text "REPL 1")) 76 | i/o-color) 77 | (colorize (box #:inset 2 (text "REPL 2")) 78 | i/o-color) 79 | (colorize (box #:inset 2 80 | #:segment 2 81 | (text "REPL n" '(italic))) 82 | i/o-color)))))) 83 | 84 | (define (back-end-source-files) 85 | (box 86 | #:outset 2 87 | #:inset 2 88 | #:color (light "gray") 89 | #:background (light "gray") 90 | (text "/tmp/racket-mode-back-end/*.rkt" 'modern 10))) 91 | 92 | (define (host name . paths) 93 | (box 94 | #:inset 5 95 | #:color "gray" 96 | #:width 2 97 | #:background host-color 98 | (vc-append 99 | 5 100 | (box #:inset 2 101 | #:background "black" 102 | (colorize (text name '(bold . modern) 14) "white")) 103 | (if (equal? name "localhost") 104 | (front-end) 105 | (back-end-source-files)) 106 | (inset (apply hc-append 10 (map backend paths)) 107 | 5)))) 108 | 109 | ;; (host "localhost" "/") 110 | ;; (host "localhost" "/" "/path/to/project") 111 | 112 | (define (scenario local . remotes) 113 | (inset 114 | (ht-append 115 | 10 116 | (apply host local) 117 | (apply vl-append 118 | 10 119 | (for/list ([remote remotes]) 120 | (apply host remote)))) 121 | 10)) 122 | 123 | (define images 124 | (list 125 | (scenario '("localhost" "/")) 126 | (scenario '("localhost" "/" "/path/to/project/")) 127 | (scenario '("localhost" "/" "/path/to/project/") 128 | '("remote" "/user@remote:/")) 129 | (scenario '("localhost" "/" "/path/to/project/") 130 | '("remote" "/user@remote:/" "/user@remote:/path/")) 131 | (scenario '("localhost" "/" "/path/to/project/") 132 | '("alpha" "/user@alpha:/" "/user@alpha:/path/") 133 | '("bravo" "/user@bravo:/" "/user@bravo:/path/")))) 134 | 135 | (module+ interactive 136 | images) 137 | 138 | (module+ main 139 | (require file/convertible) 140 | (for ([(image n) (in-indexed images)]) 141 | (with-output-to-file 142 | (format "scenario-~a.svg" n) 143 | #:exists 'replace 144 | #:mode 'binary (λ () (display (convert image 'svg-bytes)))))) 145 | -------------------------------------------------------------------------------- /doc/racket-mode.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0px auto; 3 | max-width: 768px; 4 | font-family: system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI","Roboto", "Oxygen", "Ubuntu", "Cantarell", "Fira Sans","Droid Sans", "Helvetica Neue", sans-serif; 5 | font-size: 18px; 6 | background-color: #fff; 7 | color: #333 8 | } 9 | 10 | h1, h2, h3, h4 { 11 | font-weight: 500; 12 | margin-top: 1.5em 13 | } 14 | h1 { 15 | font-size: 3em; 16 | color: #666 17 | } 18 | h1.top { 19 | margin-top: 0; 20 | } 21 | h2, h4.footnotes-heading { 22 | font-size: 3em; 23 | color: #666; 24 | border-top: 4px solid #666; 25 | } 26 | h3 { 27 | font-size: 2em; 28 | color: #666; 29 | border-top: 1px solid #ddd; 30 | } 31 | h4 { 32 | font-size: 2em; 33 | color: #444; 34 | margin-bottom: 0; 35 | } 36 | 37 | p, ol, ul { 38 | line-height: 1.6 39 | } 40 | 41 | a { 42 | text-decoration: none; 43 | color: #6e57c4; 44 | } 45 | a:hover { 46 | text-decoration:underline; 47 | } 48 | 49 | td { 50 | padding: 0.25em; 51 | } 52 | 53 | code, tt { 54 | font-family: monospace; 55 | font-size: 90%; 56 | color: #333; 57 | background-color: #f7f7f7; 58 | border: 1px solid #bbb; 59 | border-radius: 3px; 60 | padding: 0px 2px; 61 | } 62 | 63 | pre { 64 | font-family: monospace; 65 | font-size: 90%; 66 | color: #333; 67 | background-color: #f7f7f7; 68 | padding: 8px; 69 | } 70 | 71 | kbd { 72 | font-family: monospace; 73 | font-size: 90%; 74 | font-style: normal; 75 | font-weight: bold; 76 | color: #fff; 77 | background-color: #666; 78 | padding: 1px 4px; 79 | border: 1px solid #CCC; 80 | border-radius: 5px; 81 | white-space: nowrap 82 | } 83 | 84 | div.footnote h3 { 85 | font-size: 1em; 86 | margin-bottom: 0; 87 | } 88 | 89 | /* Hide some elements produced by `makeinfo' that I find redundant or noisy. */ 90 | hr { 91 | display: none; 92 | } 93 | h2.contents-heading { 94 | display: none; 95 | } 96 | -------------------------------------------------------------------------------- /racket-browse-url.el: -------------------------------------------------------------------------------- 1 | ;;; racket-browse-url.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2020 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'racket-custom) 12 | (require 'racket-cmd) 13 | (require 'racket-back-end) 14 | 15 | (defun racket-browse-url (url &rest args) 16 | (when url 17 | (apply racket-browse-url-function url args))) 18 | 19 | (defun racket-browse-file-url (path anchor) 20 | (when (or (file-remote-p path) 21 | (not (racket--back-end-local-p))) 22 | (user-error "Cannot use web browser to browse remote documentation; instead use `racket-describe'")) 23 | (racket-browse-url (concat "file://" path "#" anchor))) 24 | 25 | (defun racket-browse-url-using-temporary-file (url &rest _args) 26 | "Browse a URL via a temporary HTML file using a meta redirect. 27 | 28 | A suitable value for the variable `racket-browse-url-function'. 29 | 30 | Racket documentation URLs depend on anchors -- the portion of the 31 | URL after the # character -- to jump to a location within a page. 32 | Unfortunately on some operating systems and/or versions of Emacs, 33 | the default handling for browsing file URLs ignores anchors. This 34 | function attempts to avoid the problem by using a temporary HTML 35 | file with a meta redirect as a \"trampoline\". 36 | 37 | Although the intent is to provide a default that \"just works\", 38 | you do not need to use this. You can customize the variable 39 | `racket-browse-url-function' instead to be `browse-url', or 40 | `browse-url-browser-function' in case have have customized that, 41 | or indeed whatever you want." 42 | (let* ((url (if (string-match-p ".*://" url) url (concat "file://" url))) 43 | (file (make-temp-file "racket-browse-url-" nil ".html")) 44 | (file-uri (concat "file://" file)) 45 | (html (format "" url))) 46 | (write-region html nil file nil 'no-wrote-file-message) 47 | (browse-url file-uri))) 48 | 49 | (provide 'racket-browse-url) 50 | 51 | ;; racket-browse-url.el ends here 52 | -------------------------------------------------------------------------------- /racket-bug-report.el: -------------------------------------------------------------------------------- 1 | ;;; racket-bug-report.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2023 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'cl-macs) 12 | (require 'cus-edit) 13 | (require 'package) 14 | (require 'seq) 15 | (require 'racket-back-end) 16 | (require 'racket-cmd) 17 | (require 'racket-custom) 18 | 19 | ;;;###autoload 20 | (defun racket-bug-report () 21 | "Fill a buffer with details for a Racket Mode bug report." 22 | (interactive) 23 | (unless (string-match-p "^racket-" (symbol-name major-mode)) 24 | (user-error "Please run from a Racket Mode buffer in which you're having a problem")) 25 | (let ((original-buffer (current-buffer)) 26 | (help-window-select t) 27 | (print-length nil) ;for `pp' 28 | (print-level nil)) ;for `pp' 29 | (cl-flet* ((-section (label thunk) 30 | (princ (format "

%s

\n" label)) 31 | (princ "
\n") 32 | (funcall thunk) 33 | (princ "
\n")) 34 | (show (label value) 35 | (princ (format "
%s
" label)) 36 | (princ "
")
 37 |                  (pp value)
 38 |                  (princ "
\n")) 39 | (show-vars (syms) 40 | (with-current-buffer original-buffer 41 | (dolist (sym syms) 42 | (ignore-errors (show sym (symbol-value sym)))))) 43 | (symbol-less-p (a b) 44 | (string-lessp (symbol-name a) (symbol-name b)))) 45 | (cl-macrolet ((section (title &rest body) 46 | `(-section ,title (lambda () ,@body)))) 47 | (with-help-window "*racket-mode bug report*" 48 | (princ "Please copy all of the following lines and paste them into your bug report\n") 49 | (princ "at .\n\n") 50 | 51 | (princ "
\n") 52 | (section "Package" 53 | (show "metadata" 54 | (let ((v (assq 'racket-mode package-alist))) 55 | (and v (cdr v)))) 56 | (show-vars '(package-archives 57 | racket--el-source-dir 58 | racket--rkt-source-dir))) 59 | (section "System values" 60 | (show-vars '(emacs-version 61 | major-mode 62 | system-type 63 | x-gtk-use-system-tooltips)) 64 | (show 'display-graphic-p (display-graphic-p))) 65 | (section "Buffer values" 66 | (show-vars '(after-change-functions 67 | before-change-functions 68 | completion-at-point-functions 69 | eldoc-documentation-function 70 | eldoc-documentation-strategy 71 | eldoc-documentation-functions 72 | font-lock-defaults 73 | pre-command-hook 74 | post-command-hook 75 | post-self-insert-hook 76 | xref-backend-functions))) 77 | (section "Racket Mode values" 78 | (show 'racket--cmd-open-p (racket--cmd-open-p)) 79 | (show-vars 80 | (sort 81 | (seq-uniq 82 | (append 83 | (racket--bug-report-customs) 84 | '(racket-mode-hook 85 | racket-hash-lang-mode-hook 86 | racket-hash-lang-module-language-hook 87 | racket-repl-mode-hook 88 | racket-back-end-configurations))) 89 | #'symbol-less-p))) 90 | (section "Minor modes" 91 | (let* ((minor-modes (seq-uniq 92 | (append minor-mode-list 93 | (mapcar #'car minor-mode-alist)))) 94 | (minor-modes (sort minor-modes #'symbol-less-p)) 95 | (enabled (with-current-buffer original-buffer 96 | (seq-filter (lambda (sym) 97 | (when (ignore-errors (symbol-value sym)) 98 | sym)) 99 | minor-modes))) 100 | (disabled (with-current-buffer original-buffer 101 | (seq-filter (lambda (sym) 102 | (unless (ignore-errors (symbol-value sym)) 103 | sym)) 104 | minor-modes)))) 105 | (show 'enabled (mapcar #'list enabled)) ;so pp line-breaks 106 | (princ "
Disabled minor modes\n") 107 | (show 'disabled (mapcar #'list disabled)) 108 | (princ "
\n"))) 109 | (princ "
\n\nSteps to reproduce: ")))) 110 | (forward-line 2))) 111 | 112 | (defun racket--bug-report-customs () 113 | (let ((syms nil)) 114 | (cl-labels ((item (v) 115 | (pcase v 116 | (`(,sym custom-variable) (push sym syms)) 117 | (`(,sym custom-group) (group sym)))) 118 | (group (sym) 119 | (dolist (v (custom-group-members sym nil)) 120 | (item v)))) 121 | (group 'racket) 122 | (group 'racket-xp) 123 | (group 'racket-repl) 124 | (group 'racket-hash-lang) 125 | (group 'racket-other) 126 | syms))) 127 | 128 | (provide 'racket-bug-report) 129 | 130 | ;;; racket-bug-report.el ends here 131 | -------------------------------------------------------------------------------- /racket-complete.el: -------------------------------------------------------------------------------- 1 | ;;; racket-complete.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'racket-common) 12 | 13 | (defun racket--call-with-completion-prefix-positions (proc) 14 | (cl-flet ((maybe-call (beg end) 15 | (when (and (<= (+ beg 2) end) ;prefix at least 2 chars 16 | (eq (line-number-at-pos beg) 17 | (line-number-at-pos end))) 18 | (funcall proc beg end)))) 19 | (if forward-sexp-function ;not necessarily sexp lang 20 | (condition-case _ 21 | (save-excursion 22 | (let ((beg (progn (forward-sexp -1) (point))) 23 | (end (progn (forward-sexp 1) (point)))) 24 | (maybe-call beg end))) 25 | (error nil)) 26 | (let ((beg (save-excursion (skip-syntax-backward "^-()>") (point)))) 27 | (unless (or (eq beg (point-max)) 28 | (member (char-syntax (char-after beg)) '(?\" ?\( ?\)))) 29 | (condition-case _ 30 | (save-excursion 31 | (goto-char beg) 32 | (forward-sexp 1) 33 | (maybe-call beg (point))) 34 | (error nil))))))) 35 | 36 | (defun racket--in-require-form-p () 37 | (unless forward-sexp-function ;not necessarily sexp lang 38 | (save-excursion 39 | (save-match-data 40 | (racket--escape-string-or-comment) 41 | (let ((done nil) 42 | (result nil)) 43 | (condition-case _ 44 | (while (not done) 45 | (backward-up-list) 46 | (when (looking-at-p (rx ?\( (or "require" "#%require"))) 47 | (setq done t) 48 | (setq result t))) 49 | (scan-error nil)) 50 | result))))) 51 | 52 | ;;; Completion tables with "category" metadata 53 | 54 | (defconst racket--identifier-category 'racket-identifier 55 | "Value for category metadata of identifier completion tables.") 56 | 57 | ;; Suggest default; can customize via `completion-category-overrides'. 58 | (add-to-list 'completion-category-defaults 59 | `(,racket--identifier-category (styles basic))) 60 | 61 | (defconst racket--module-category 'racket-module 62 | "Value for category metadata of module completion tables.") 63 | 64 | ;; Suggest default; can customize via `completion-category-overrides'. 65 | (add-to-list 'completion-category-defaults 66 | `(,racket--module-category (styles basic))) 67 | 68 | (defun racket--completion-table (completions &optional metadata) 69 | "Like `completion-table-dynamic' but also supplies metadata. 70 | 71 | METADATA defaults to `((category . ,`racket--identifier-category')). 72 | 73 | Although sometimes completion metadata is specified as properties 74 | in a `completion-at-point-functions' item, sometimes that is 75 | insufficient or irrelevant -- as with category metadata, or, when 76 | CAPF isn't involved and instead the completion table is given 77 | directly to `completing-read'. 78 | 79 | Supplying category metadata allows the user to configure a 80 | completion matching style for that category. It also prevents 81 | third party packages like marginalia from misclassifying and 82 | displaying inappropriate annotations." 83 | (lambda (prefix predicate action) 84 | (pcase action 85 | ('metadata 86 | (cons 'metadata 87 | (or metadata 88 | `((category . ,racket--identifier-category))))) 89 | (_ 90 | (complete-with-action action completions prefix predicate))))) 91 | 92 | (defun racket--make-affix (specs &optional prop) 93 | "Make an affixation-function to show completion annotations. 94 | 95 | For more information about affixation-function completion 96 | metadata, see Info node `(elisp)Programmed Completion'. 97 | 98 | PROP is the symbol name of a text property that must be attached 99 | to each of the completion candidate strings. The value of the 100 | property is a list of strings -- each string is a suffix column 101 | value to show as an annotation. The list length must be the same 102 | for all candidate strings. The property name defaults to 103 | \\='racket-affix. 104 | 105 | SPECS is a vector of specs for each column -- one for the 106 | completion candidate string, plus the length of the list of 107 | suffix columns. Each spec may be an integer, which is a minimum 108 | width, or [WIDTH FACE]. Note: The width is N/A for the last 109 | suffix column. The face is N/A for the first column, which shows 110 | the candidate string. For suffix columns, the face defaults to 111 | completions-anntoations. An explicit nil value in the spec means 112 | not to add a face, because the string is already propertized with 113 | one. 114 | 115 | The affixation-function arranges for each suffix column to be 116 | aligned, considering the minimum width and the maximum width of 117 | the previous column. 118 | 119 | When a candidate string ends with text made invisible by a 120 | \\='display \"\" property -- as is done by 121 | `racket--doc-index-make-alist' -- that text is ignored for 122 | purposes of calculating widths." 123 | ;; Note: Below we use `cl-loop' because `seq-do-indexed' and 124 | ;; `seq-map-indexed' are unavailable in Emacs 25. 125 | (let ((min-widths (cl-loop 126 | for spec across specs 127 | collect (pcase spec 128 | (`[,width ,_face] width) 129 | ((and (pred numberp) width) width) 130 | (_ 0)))) 131 | (suffix-faces (cl-loop for spec across (seq-drop specs 1) 132 | collect (pcase spec 133 | (`[,_width ,face] face) 134 | (_ 'completions-annotations)))) 135 | (prop (or prop 'racket-affix))) 136 | (lambda (strs) 137 | (let* ((max-widths (apply #'vector min-widths)) 138 | (rows 139 | (cl-loop 140 | for str in strs 141 | collect 142 | (let ((visible-str 143 | (substring str 144 | 0 145 | (text-property-any 0 (length str) 146 | 'display "" 147 | str))) 148 | (suffixes (get-text-property 0 prop str))) 149 | ;; Mutate `max-widths'. 150 | (cl-loop 151 | for col in (cons visible-str suffixes) 152 | for ix from 0 153 | do (aset max-widths ix 154 | (max (aref max-widths ix) 155 | (1+ (length col))))) 156 | (cons str suffixes)))) 157 | (suffix-offsets 158 | (let ((offset 0)) 159 | (cl-loop 160 | for max-width across max-widths 161 | collect 162 | (setq offset (+ offset max-width)))))) 163 | (cl-loop 164 | for row in rows 165 | collect 166 | (pcase-let* 167 | ((`(,str . ,suffixes) row) 168 | (suffixes-str 169 | (cl-loop 170 | for suffix in suffixes 171 | for offset in suffix-offsets 172 | for face in suffix-faces 173 | concat 174 | (concat 175 | (propertize " " 176 | 'display 177 | `(space :align-to ,offset)) 178 | (if face 179 | (propertize (or suffix "") 180 | 'face face) 181 | (or suffix "")))))) 182 | (list str "" suffixes-str))))))) 183 | 184 | (provide 'racket-complete) 185 | 186 | ;; racket-complete.el ends here 187 | -------------------------------------------------------------------------------- /racket-doc.el: -------------------------------------------------------------------------------- 1 | ;;; racket-doc.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2020 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'url-util) 12 | (require 'racket-browse-url) 13 | (require 'racket-cmd) 14 | (require 'racket-custom) 15 | (require 'racket-util) 16 | (require 'racket-back-end) 17 | (declare-function racket--repl-session-id "racket-repl.el" ()) 18 | 19 | (defun racket--doc-assert-local-back-end () 20 | (unless (racket--back-end-local-p) 21 | (user-error "Cannot use web browser to browse remote documentation; instead use `racket-describe'"))) 22 | 23 | (defun racket--doc (prefix how completions) 24 | "A helper for `racket-xp-documentation' and `racket-repl-documentation'." 25 | (racket--doc-assert-local-back-end) 26 | (cond 27 | ((equal prefix '(16)) 28 | (when-let (str (read-from-minibuffer 29 | "Search documentation for text: ")) 30 | (racket--search-doc str))) 31 | (t 32 | (when-let (str (racket--symbol-at-point-or-prompt 33 | prefix 34 | "Documentation for: " 35 | completions)) 36 | (racket--doc-command (when (eq how 'namespace) 37 | (racket--repl-session-id)) 38 | how 39 | str))))) 40 | 41 | (defun racket--doc-command (repl-session-id how str) 42 | "A helper for `racket--doc', `racket-xp-describe', and `racket-repl-describe'. 43 | 44 | Centralizes how to issue doc command and handle response correctly." 45 | (let ((how (racket-how-front-to-back how))) 46 | (racket--cmd/async repl-session-id 47 | `(doc ,how ,str) 48 | (lambda (maybe-url) 49 | (if maybe-url 50 | (racket-browse-url maybe-url) 51 | (racket--search-doc str)))))) 52 | 53 | (defun racket--search-doc (str) 54 | "Search docs where the variable `racket-documentation-search-location' says." 55 | (pcase racket-documentation-search-location 56 | ((and (pred stringp) url) (racket-browse-url (format url (url-hexify-string str)))) 57 | ('local (racket--search-doc-locally str)) 58 | (_ (user-error "Unknown value for `racket-documentation-search-location': %s" 59 | racket-documentation-search-location)))) 60 | 61 | (defun racket--search-doc-locally (str) 62 | (racket--doc-assert-local-back-end) 63 | (let ((command (if (stringp racket-program) 64 | (list racket-program) 65 | racket-program))) 66 | (apply #'call-process `(,(car command) 67 | nil ;INFILE: none 68 | 0 ;DESTINATION: discard/don't wait 69 | nil ;DISPLAY: none 70 | ,@(cdr command) 71 | "-l" "raco" "docs" ,str)))) 72 | 73 | (provide 'racket-doc) 74 | 75 | ;; racket-doc.el ends here 76 | -------------------------------------------------------------------------------- /racket-eldoc.el: -------------------------------------------------------------------------------- 1 | ;;; racket-eldoc.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (defun racket--eldoc-do-callback (callback thing str) 12 | (if str 13 | (funcall callback 14 | str 15 | :thing thing 16 | :face 'font-lock-function-name-face) 17 | (funcall callback nil)) 18 | t) 19 | 20 | (provide 'racket-eldoc) 21 | 22 | ;; racket-eldoc.el ends here 23 | -------------------------------------------------------------------------------- /racket-imenu.el: -------------------------------------------------------------------------------- 1 | ;;; racket-imenu.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2021 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'cl-lib) 12 | (require 'imenu) 13 | 14 | (defun racket-imenu-create-index-function () 15 | "A function for the variable `imenu-create-index-function'." 16 | (save-excursion 17 | (goto-char (point-min)) 18 | (racket--imenu-goto-start-of-current-sexp) 19 | (racket--imenu-walk))) 20 | 21 | (defun racket--imenu-walk () 22 | "With point at the start of a sexp, walk all the sepxs. 23 | 24 | Note that `racket--imenu-item' will walk into Racket module forms 25 | and call us recursively." 26 | (cl-loop append (racket--imenu-item) into xs 27 | while (racket--imenu-goto-start-of-following-sexp) 28 | finally return xs)) 29 | 30 | (defun racket--imenu-item () 31 | "Return the identifier for the sexp at point if any, else nil. 32 | 33 | If sexp at point is a Racket module form create a submenu." 34 | (save-match-data 35 | (cond ((looking-at (rx "(define" (* (or (syntax word) 36 | (syntax symbol) 37 | (syntax punctuation))) 38 | (+ (syntax whitespace)) 39 | (* ?\() 40 | (group (+ (or (syntax word) 41 | (syntax symbol) 42 | (syntax punctuation)))))) 43 | (list (cons (match-string-no-properties 1) 44 | (if imenu-use-markers 45 | (copy-marker (match-beginning 1)) 46 | (match-beginning 1))))) 47 | ((looking-at (rx "(module" (? (any ?+ ?*)) 48 | (+ (syntax whitespace)) 49 | (group (+ (or (syntax word) 50 | (syntax symbol) 51 | (syntax punctuation)))))) 52 | (save-excursion 53 | (goto-char (match-end 1)) 54 | (racket--imenu-goto-start-of-current-sexp) 55 | (list (cons (concat "Module: " (match-string-no-properties 1)) 56 | (racket--imenu-walk ))))) 57 | (t nil)))) 58 | 59 | (defun racket--imenu-goto-start-of-current-sexp () 60 | (ignore-errors 61 | (forward-sexp 1) 62 | (forward-sexp -1))) 63 | 64 | (defun racket--imenu-goto-start-of-following-sexp () 65 | (condition-case _ 66 | (progn 67 | (forward-sexp 1) 68 | (let ((orig (point))) 69 | (forward-sexp 1) 70 | (if (or (eobp) (equal orig (point))) 71 | nil 72 | (forward-sexp -1) 73 | t))) 74 | (scan-error nil))) 75 | 76 | (provide 'racket-imenu) 77 | 78 | ;;; racket-imenu.el ends here 79 | -------------------------------------------------------------------------------- /racket-lisp-mode.el: -------------------------------------------------------------------------------- 1 | ;;; racket-lisp-mode.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | ;; Some packages like paredit and lispy directly call `lisp-mode' 12 | ;; functions `lisp-indent-line' and `indent-sexp'. (As opposed to 13 | ;; calling functions like `indent-line-to' and `prog-indent-sexp' that 14 | ;; a mode can specialize via `indent-line-function' and 15 | ;; `indent-region-function'.) 16 | ;; 17 | ;; Although that's fine for modes like `scheme-mode' derived from 18 | ;; `lisp-mode', `racket-mode' is not. 19 | ;; 20 | ;; Therefore if users want to use such packages hardwired to call 21 | ;; those two `lisp-mode' function, AFAICT we have no choice but to 22 | ;; advise those two functions. :( 23 | ;; 24 | ;; Furthermore lisp-mode's `indent-sexp' differs from 25 | ;; `prog-indent-sexp' as explained below in the doc string for 26 | ;; `racket-indent-sexp-contents'. 27 | 28 | (require 'lisp-mode) 29 | (require 'racket-util) 30 | 31 | (defun racket--lisp-indent-line-advice (orig &rest args) 32 | (apply (if (racket--mode-edits-racket-p) 33 | indent-line-function 34 | orig) 35 | args)) 36 | 37 | (advice-add #'lisp-indent-line :around #'racket--lisp-indent-line-advice) 38 | 39 | (defun racket--indent-sexp-advice (orig &rest args) 40 | (apply (if (racket--mode-edits-racket-p) 41 | #'racket-indent-sexp-contents 42 | orig) 43 | args)) 44 | 45 | (advice-add #'indent-sexp :around #'racket--indent-sexp-advice) 46 | 47 | (defun racket-indent-sexp-contents () 48 | "Indent each line of the sexp starting just after point. 49 | 50 | Unlike `prog-indent-sexp', which indents the entire sexp, this 51 | does /not/ indent the first line at point, just subsequent lines 52 | if any. In other words it does not indent the sexp as a whole, 53 | just its contents. In this regard it behaves like the 54 | `lisp-mode'-specific function `indent-sexp'." 55 | (interactive) 56 | (condition-case _ 57 | (let ((beg-of-2nd-line (save-excursion (forward-line 1) (point))) 58 | (end-of-expression (save-excursion (forward-sexp 1) (point)))) 59 | (when (< beg-of-2nd-line end-of-expression) 60 | (indent-region beg-of-2nd-line end-of-expression))) 61 | (scan-error nil))) 62 | 63 | (provide 'racket-lisp-mode) 64 | 65 | ;; racket-lisp-mode.el ends here 66 | -------------------------------------------------------------------------------- /racket-logger.el: -------------------------------------------------------------------------------- 1 | ;;; racket-logger.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'compat) ;for text-property-search-{forward backward} 12 | (require 'easymenu) 13 | (require 'rx) 14 | (require 'racket-custom) 15 | (require 'racket-repl) 16 | (require 'racket-back-end) 17 | 18 | ;; Need to define this before racket-logger-mode 19 | (defvar racket-logger-mode-map 20 | (racket--easy-keymap-define 21 | '(("l" racket-logger-topic-level) 22 | ("w" toggle-truncate-lines) 23 | ("n" racket-logger-next-item) 24 | ("p" racket-logger-previous-item) 25 | ("g" racket-logger-clear)))) 26 | 27 | (easy-menu-define racket-logger-mode-menu racket-logger-mode-map 28 | "Menu for Racket logger mode." 29 | '("Racket-Logger" 30 | ["Configure Topic and Level" racket-logger-topic-level] 31 | ["Toggle Truncate Lines" toggle-truncate-lines] 32 | "---" 33 | ["Clear" racket-logger-clear])) 34 | 35 | (define-derived-mode racket-logger-mode special-mode "Racket-Logger" 36 | "Major mode for Racket logger output. 37 | \\ 38 | 39 | The customization variable `racket-logger-config' determines the 40 | levels for topics. During a session you may change topic levels 41 | using `racket-logger-topic-level'. 42 | 43 | For more information see: 44 | 45 | 46 | \\{racket-logger-mode-map} 47 | " 48 | (setq-local font-lock-defaults (list nil t)) ;no font lock 49 | (setq-local truncate-lines t) 50 | (setq-local buffer-undo-list t) ;disable undo 51 | (setq-local window-point-insertion-type t)) 52 | 53 | (defun racket--logger-buffer-name (&optional back-end-name) 54 | (format "*Racket Logger <%s>*" (or back-end-name 55 | (racket-back-end-name)))) 56 | 57 | (defun racket--logger-get-buffer-create (&optional back-end-name) 58 | "Create buffer if necessary. Do not display or select it." 59 | (let ((name (racket--logger-buffer-name back-end-name))) 60 | (unless (get-buffer name) 61 | (with-current-buffer (get-buffer-create name) 62 | (racket-logger-mode) 63 | (racket--logger-activate-config))) 64 | (get-buffer name))) 65 | 66 | (defun racket--logger-on-notify (back-end-name v) 67 | "This is called from `racket--cmd-dispatch-response'. 68 | 69 | As a result, we might create this buffer before the user does a 70 | `racket-logger-mode' command." 71 | (when noninteractive ;emacs --batch 72 | (princ (format "{logger %s}: %s" 73 | (racket-back-end-name) 74 | v))) 75 | (with-current-buffer (racket--logger-get-buffer-create back-end-name) 76 | (pcase-let* ((`(,level ,topic ,message) v) 77 | (`(,level-str . ,level-face) 78 | (pcase level 79 | ('fatal (cons "[ fatal]" racket-logger-fatal-face)) 80 | ('error (cons "[ error]" racket-logger-error-face)) 81 | ('warning (cons "[warning]" racket-logger-warning-face)) 82 | ('info (cons "[ info]" racket-logger-info-face)) 83 | ('debug (cons "[ debug]" racket-logger-debug-face)))) 84 | (inhibit-read-only t) 85 | (original-point (point)) 86 | (point-was-at-end-p (equal original-point (point-max)))) 87 | (goto-char (point-max)) 88 | (insert (propertize level-str 89 | 'face level-face 90 | 'racket-logger-item-level t) 91 | " " 92 | (propertize (symbol-name topic) 93 | 'face racket-logger-topic-face) 94 | ": " 95 | message 96 | "\n") 97 | (unless point-was-at-end-p 98 | (goto-char original-point))))) 99 | 100 | (defun racket--logger-activate-config () 101 | "Send config to logger and display it in the buffer." 102 | (racket--cmd/async nil 103 | `(logger ,racket-logger-config)) 104 | (with-current-buffer (racket--logger-get-buffer-create) 105 | (let ((inhibit-read-only t)) 106 | (goto-char (point-max)) 107 | (insert (propertize (concat "racket-logger-config:\n" 108 | (pp-to-string racket-logger-config)) 109 | 'face racket-logger-config-face)) 110 | (goto-char (point-max))))) 111 | 112 | (defun racket--logger-set (topic level) 113 | (unless (symbolp topic) (error "TOPIC must be symbolp")) 114 | (unless (symbolp level) (error "LEVEL must be symbolp")) 115 | (pcase (assq topic racket-logger-config) 116 | (`() (add-to-list 'racket-logger-config (cons topic level))) 117 | (v (setcdr v level))) 118 | (racket--logger-activate-config)) 119 | 120 | (defun racket--logger-unset (topic) 121 | (unless (symbolp topic) (error "TOPIC must be symbolp")) 122 | (when (eq topic '*) 123 | (user-error "Cannot unset the level for the '* topic")) 124 | (setq racket-logger-config 125 | (assq-delete-all topic racket-logger-config)) 126 | (racket--logger-activate-config)) 127 | 128 | (defun racket--logger-topics () 129 | "Effectively (sort (dict-keys racket-logger-config))." 130 | (sort (mapcar (lambda (x) (format "%s" (car x))) 131 | racket-logger-config) 132 | #'string<)) 133 | 134 | (defun racket--logger-topic-level (topic not-found) 135 | "Effectively (dict-ref racket-logger-config topic not-found)." 136 | (or (cdr (assq topic racket-logger-config)) 137 | not-found)) 138 | 139 | ;;; commands 140 | 141 | (defun racket-logger () 142 | "Create the `racket-logger-mode' buffer." 143 | (interactive) 144 | (racket--logger-get-buffer-create) 145 | ;; Give it a window if necessary 146 | (unless (get-buffer-window (racket--logger-buffer-name)) 147 | (display-buffer (get-buffer (racket--logger-buffer-name)))) 148 | ;; Select the window 149 | (select-window (get-buffer-window (racket--logger-buffer-name)))) 150 | 151 | (defun racket-logger-clear () 152 | "Clear the buffer and reconnect." 153 | (interactive) 154 | (when (eq major-mode 'racket-logger-mode) 155 | (when (y-or-n-p "Clear buffer? ") 156 | (let ((inhibit-read-only t)) 157 | (delete-region (point-min) (point-max))) 158 | (racket--logger-activate-config)))) 159 | 160 | (defun racket-logger-next-item (&optional count) 161 | "Move point forward COUNT logger output items. 162 | 163 | Interactively, COUNT is the numeric prefix argument. If COUNT is 164 | omitted or nil, move point 1 item forward." 165 | (interactive "p") 166 | (let* ((count (or count 1)) 167 | (step (if (< 0 count) -1 1)) 168 | (search (if (< 0 count) 169 | #'text-property-search-forward 170 | #'text-property-search-backward))) 171 | (while (not (zerop count)) 172 | (let ((match (funcall search 'racket-logger-item-level t t t))) 173 | (if (not match) 174 | (setq count 0) 175 | (goto-char (prop-match-beginning match)) 176 | (setq count (+ count step))))))) 177 | 178 | (defun racket-logger-previous-item (&optional count) 179 | "Move point backward COUNT logger output items. 180 | 181 | Interactively, COUNT is the numeric prefix argument. If COUNT is 182 | omitted or nil, move point 1 item backward." 183 | (interactive "p") 184 | (racket-logger-next-item (if count (- count) -1))) 185 | 186 | (defun racket-logger-topic-level () 187 | "Set or unset the level for a topic. 188 | 189 | The topic labeled \"*\" is the level to use for all topics not 190 | specifically assigned a level. 191 | 192 | The level choice \"*\" means the topic will no longer have its 193 | own level, therefore will follow the level specified for the 194 | \"*\" topic." 195 | (interactive) 196 | (let* ((topic (completing-read 197 | "Topic: " 198 | (racket--logger-topics))) 199 | (topic (pcase topic 200 | ("" "*") 201 | (v v))) 202 | (topic (intern topic)) 203 | (levels (list "fatal" "error" "warning" "info" "debug")) 204 | (levels (if (eq topic '*) levels (cons "*" levels))) 205 | (level (completing-read 206 | (format "Level for topic `%s': " topic) 207 | levels 208 | nil t nil nil 209 | (format "%s" (racket--logger-topic-level topic "*")))) 210 | (level (pcase level 211 | ("" nil) 212 | ("*" nil) 213 | (v (intern v))))) 214 | (if level 215 | (racket--logger-set topic level) 216 | (racket--logger-unset topic)))) 217 | 218 | (provide 'racket-logger) 219 | 220 | ;;; racket-logger.el ends here 221 | -------------------------------------------------------------------------------- /racket-parens.el: -------------------------------------------------------------------------------- 1 | ;;; racket-parens.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | ;; Things related to parens, paredit, electric-pair-mode 12 | 13 | (require 'racket-custom) 14 | (require 'racket-ppss) 15 | (require 'racket-util) 16 | 17 | ;;; racket--self-insert 18 | 19 | (defun racket--self-insert (event) 20 | "Simulate a `self-insert-command' of EVENT. 21 | 22 | Using this intead of `insert' allows self-insert hooks to run, 23 | which is important for things like `electric-pair-mode'. 24 | 25 | A command using this should probably set its delete-selection 26 | property to t so that `delete-selection-mode' works: 27 | 28 | (put \\='racket-command \\='delete-selection t) 29 | 30 | If necessary the value of the property can be a function, for 31 | example `racket--electric-pair-mode-not-active'." 32 | (let ((last-command-event event)) ;set this for hooks 33 | (self-insert-command (prefix-numeric-value nil)))) 34 | 35 | (defun racket--electric-pair-mode-not-active () 36 | "A suitable value for the delete-selection property of commands 37 | that insert parens: Inserted text should replace the selection 38 | unless a mode like `electric-pair-mode' is enabled, in which case 39 | the selection is to be wrapped in parens." 40 | (not (and (boundp 'electric-pair-mode) 41 | electric-pair-mode))) 42 | 43 | 44 | ;;; Automatically insert matching \?) \?] or \?} 45 | 46 | (defconst racket--matching-parens 47 | '(( ?\( . ?\) ) 48 | ( ?\[ . ?\] ) 49 | ( ?\{ . ?\} ))) 50 | 51 | (defun racket-insert-closing (&optional prefix) 52 | "Insert a matching closing delimiter. 53 | 54 | With \\[universal-argument] insert the typed character as-is. 55 | 56 | This is handy if you're not yet using something like 57 | `paredit-mode', `smartparens-mode', `parinfer-mode', or simply 58 | `electric-pair-mode' added in Emacs 24.5." 59 | (interactive "P") 60 | (let* ((do-it (not (or prefix 61 | (and (string= "#\\" 62 | (buffer-substring-no-properties 63 | (- (point) 2) (point) ))) 64 | (racket--ppss-string-p (syntax-ppss))))) 65 | (open-char (and do-it (racket--open-paren #'backward-up-list))) 66 | (close-pair (and open-char (assq open-char racket--matching-parens))) 67 | (close-char (and close-pair (cdr close-pair)))) 68 | (racket--self-insert (or close-char last-command-event)))) 69 | 70 | (put 'racket-insert-closing 'delete-selection 71 | #'racket--electric-pair-mode-not-active) 72 | 73 | (defun racket--open-paren (back-func) 74 | "Use BACK-FUNC to find an opening ( [ or { if any. 75 | BACK-FUNC should be something like #\\='backward-sexp or #\\='backward-up-list." 76 | (save-excursion 77 | (ignore-errors 78 | (funcall back-func) 79 | (let ((ch (char-after))) 80 | (and (eq ?\( (char-syntax ch)) 81 | ch))))) 82 | 83 | ;;; paredit spaces in reader literals and at-expressions 84 | 85 | (defun racket--paredit-space-for-delimiter-predicate (endp delimiter) 86 | "A value for hook `paredit-space-for-delimiter-predicates'." 87 | (if (and (racket--mode-edits-racket-p) 88 | (not endp)) 89 | (not 90 | (or 91 | ;; reader literal: e.g. #(), #hasheq(), #"bstr", #px".*" 92 | (looking-back (rx ?# (* (or (syntax word) 93 | (syntax symbol) 94 | (syntax punctuation)))) 95 | nil) 96 | ;; at-expression: @foo[ @foo{ 97 | (and (memq delimiter '(?\[ ?\{)) 98 | (looking-back (rx ?@ (* (or (syntax word) 99 | (syntax symbol) 100 | (syntax punctuation)))) 101 | nil)) 102 | ;; at-expression: @foo[]{ 103 | (and (eq delimiter ?\{) 104 | (looking-back (rx ?@ (* (or (syntax word) 105 | (syntax symbol) 106 | (syntax punctuation))) 107 | ?\[ 108 | (* (or (syntax word) 109 | (syntax symbol) 110 | (syntax punctuation))) 111 | ?\]) 112 | nil)) 113 | )) 114 | t)) 115 | 116 | ;;; Cycle paren shapes 117 | 118 | (defconst racket--paren-shapes 119 | '( (?\( ?\[ ?\] ) 120 | (?\[ ?\{ ?\} ) 121 | (?\{ ?\( ?\) )) 122 | "This is not user-configurable because we expect them have to 123 | have actual ?\( and ?\) char syntax.") 124 | 125 | (defun racket-cycle-paren-shapes () 126 | "Cycle the sexpr among () [] {}." 127 | (interactive) 128 | (racket--assert-sexp-edit-mode) 129 | (save-excursion 130 | (unless (eq ?\( (char-syntax (char-after))) 131 | (backward-up-list)) 132 | (pcase (assq (char-after) racket--paren-shapes) 133 | (`(,_ ,open ,close) 134 | (delete-char 1) 135 | (insert open) 136 | (backward-char 1) 137 | (forward-sexp 1) 138 | (delete-char -1) 139 | (insert close)) 140 | (_ 141 | (user-error "Don't know that paren shape"))))) 142 | 143 | (provide 'racket-parens) 144 | 145 | ;; racket-parens.el ends here 146 | -------------------------------------------------------------------------------- /racket-ppss.el: -------------------------------------------------------------------------------- 1 | ;;; racket-ppss.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2020 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | ;; Note: These doc strings are from the Parser State info topic, as of 12 | ;; Emacs 25.1. 13 | 14 | (defun racket--ppss-paren-depth (xs) 15 | "The depth in parentheses, counting from 0. 16 | *Warning:* this can be negative if there are more close parens 17 | than open parens between the parser’s starting point and end 18 | point." 19 | (elt xs 0)) 20 | 21 | (defun racket--ppss-containing-sexp (xs) 22 | "The character position of the start of the innermost parenthetical 23 | grouping containing the stopping point; nil if none." 24 | (elt xs 1)) 25 | 26 | (defun racket--ppss-last-sexp (xs) 27 | "The character position of the start of the last complete 28 | subexpression terminated; nil if none. 29 | Valid only for `parse-partial-sexp' -- NOT `syntax-ppss'." 30 | (elt xs 2)) 31 | 32 | (defun racket--ppss-string-p (xs) 33 | "Non-nil if inside a string. 34 | More precisely, this is the character that will terminate the 35 | string, or t if a generic string delimiter character should 36 | terminate it." 37 | (elt xs 3)) 38 | 39 | (defun racket--ppss-comment-p (xs) 40 | "t if inside a non-nestable comment (of any comment style; 41 | *note Syntax Flags::); or the comment nesting level if inside a 42 | comment that can be nested." 43 | (elt xs 4)) 44 | 45 | (defun racket--ppss-quote-p (xs) 46 | "t if the end point is just after a quote character." 47 | (elt xs 5)) 48 | 49 | (defun racket--ppss-min-paren-depth (xs) 50 | "The minimum parenthesis depth encountered during this scan. 51 | Valid only for `parse-partial-sexp' -- NOT `syntax-ppss'." 52 | (elt xs 6)) 53 | 54 | (defun racket--ppss-comment-type (xs) 55 | "What kind of comment is active: nil if not in a comment or 56 | in a comment of style a; 1 for a comment of style b; 2 for a 57 | comment of style c; and syntax-table for a comment that 58 | should be ended by a generic comment delimiter character." 59 | (elt xs 7)) 60 | 61 | (defun racket--ppss-string/comment-start (xs) 62 | "The string or comment start position. 63 | While inside a comment, this is the position where the comment 64 | began; while inside a string, this is the position where the 65 | string began. When outside of strings and comments, this element 66 | is nil." 67 | (elt xs 8)) 68 | 69 | (provide 'racket-ppss) 70 | 71 | ;; racket-ppss.el ends here 72 | -------------------------------------------------------------------------------- /racket-profile.el: -------------------------------------------------------------------------------- 1 | ;;; racket-profile.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'racket-repl) 12 | (require 'racket-util) 13 | (require 'racket-back-end) 14 | 15 | (defvar-local racket--profile-project-root nil) 16 | (defvar-local racket--profile-results nil) 17 | (defvar-local racket--profile-show-zero nil) 18 | (defvar-local racket--profile-show-non-project nil) 19 | 20 | (defun racket-profile () 21 | "Like `racket-run-module-at-point' but with profiling. 22 | 23 | Results are presented in a `racket-profile-mode' buffer, which 24 | also lets you quickly view the source code. 25 | 26 | You may evaluate expressions in the REPL. They are also profiled. 27 | Use `racket-profile-refresh' to see the updated results. In 28 | other words a possible workflow is: `racket-profile' a .rkt file, 29 | call one its functions in the REPL, and refresh the profile 30 | results. 31 | 32 | Caveat: Only source files are instrumented. You may need to 33 | delete compiled/*.zo files." 34 | (interactive) 35 | (racket--assert-edit-mode) 36 | (message "Running with profiling instrumentation...") 37 | (let ((buf-name (format "*Racket Profile <%s>*" 38 | (racket-back-end-name))) 39 | (what-to-run (racket--what-to-run))) 40 | (racket--repl-run 41 | what-to-run 42 | '() 43 | 'profile 44 | (lambda () 45 | (message "Getting profile results...") 46 | (racket--cmd/async 47 | (racket--repl-session-id) 48 | `(get-profile) 49 | (lambda (results) 50 | (message "Preparing profile results to display...") 51 | (with-current-buffer 52 | (get-buffer-create buf-name) 53 | (racket-profile-mode) 54 | (setq racket--profile-results results) 55 | (setq racket--profile-project-root 56 | (racket-project-root (car what-to-run))) 57 | (racket--profile-draw) 58 | (pop-to-buffer (current-buffer))))))))) 59 | 60 | (defun racket-profile-refresh () 61 | (interactive) 62 | (racket--cmd/async (racket--repl-session-id) 63 | `(get-profile) 64 | (lambda (results) 65 | (setq racket--profile-results 66 | results) 67 | (racket--profile-draw)))) 68 | 69 | (defun racket--profile-draw () 70 | (setq truncate-lines t) ;let run off right edge 71 | (with-silent-modifications 72 | (erase-buffer) 73 | (pcase-let* ((filtered (seq-filter 74 | (pcase-lambda (`(,calls ,msec ,_name ,file ,_beg ,_end)) 75 | (and (or racket--profile-show-zero 76 | (not (and (zerop calls) (zerop msec)))) 77 | (or racket--profile-show-non-project 78 | (equal (racket-project-root 79 | (racket-file-name-back-to-front file)) 80 | racket--profile-project-root)))) 81 | racket--profile-results)) 82 | (`(,width-calls ,width-msec ,width-name) 83 | (seq-reduce (pcase-lambda (`(,width-calls ,width-msec ,width-name) 84 | `(,calls ,msec ,name . ,_)) 85 | (list (max width-calls (length (format "%s" calls))) 86 | (max width-msec (length (format "%s" msec))) 87 | (max width-name (length name)))) 88 | filtered 89 | `(5 5 4)))) 90 | (cl-flet ((sort-pred (col) (lambda (a b) 91 | (< (string-to-number (aref (cadr a) col)) 92 | (string-to-number (aref (cadr b) col)))))) 93 | (setq tabulated-list-format 94 | `[("Calls" ,width-calls ,(sort-pred 0) :right-align t) 95 | ("Msec" ,width-msec ,(sort-pred 1) :right-align t) 96 | ("Name" ,width-name t) 97 | ("Source" 99 t)])) 98 | (setq tabulated-list-entries 99 | (seq-map (pcase-lambda (`(,calls ,msec ,name ,file ,beg ,end)) 100 | (let* ((file (racket-file-name-back-to-front file)) 101 | (simplified-file 102 | (if (equal (racket-project-root file) 103 | racket--profile-project-root) 104 | (file-relative-name file racket--profile-project-root) 105 | file))) 106 | (list nil 107 | (vector 108 | (format "%s" calls) 109 | (format "%s" msec) 110 | (propertize (or name "") 111 | 'face font-lock-function-name-face) 112 | (if (and file beg end) 113 | (list simplified-file 114 | 'racket-file file 115 | 'racket-beg beg 116 | 'racket-end end 117 | 'action #'racket-profile-button) 118 | simplified-file))))) 119 | filtered)) 120 | (tabulated-list-init-header) 121 | (tabulated-list-print) 122 | (save-excursion 123 | (goto-char (point-max)) 124 | (newline) 125 | (insert (concat (if racket--profile-show-zero "Showing" "Hiding") 126 | " 0 calls and 0 msec. Press z to toggle.")) 127 | (newline) 128 | (insert (concat (if racket--profile-show-non-project "Showing" "Hiding") 129 | " non-project files. Press f to toggle.")))))) 130 | 131 | (defun racket-profile-button (button) 132 | (let ((file (button-get button 'racket-file)) 133 | (beg (button-get button 'racket-beg))) 134 | (xref-push-marker-stack) 135 | (find-file file) 136 | (goto-char beg))) 137 | 138 | (defun racket-profile-visit () 139 | "Visit the source of the profile item. 140 | 141 | Use \\[xref-pop-marker-stack] -- `xref-pop-marker-stack' -- to return." 142 | (interactive) 143 | (pcase (tabulated-list-get-entry (point)) 144 | (`[,_calls ,_msec ,_name (,_ racket-file ,file racket-beg ,beg . ,_)] 145 | (xref-push-marker-stack) 146 | (find-file file) 147 | (goto-char beg)))) 148 | 149 | (defun racket-profile-show-zero () 150 | "Toggle between showing results with zero Calls or Msec." 151 | (interactive) 152 | (setq racket--profile-show-zero (not racket--profile-show-zero)) 153 | (racket--profile-draw)) 154 | 155 | (defun racket-profile-show-non-project () 156 | "Toggle between showing results for files only in the project. 157 | 158 | The \"project\" is determined by `racket-project-root'." 159 | (interactive) 160 | (setq racket--profile-show-non-project (not racket--profile-show-non-project)) 161 | (racket--profile-draw)) 162 | 163 | (defvar racket-profile-mode-map 164 | (let ((m (make-sparse-keymap))) 165 | (set-keymap-parent m nil) 166 | (mapc (lambda (x) 167 | (define-key m (kbd (car x)) (cadr x))) 168 | '(("q" quit-window) 169 | ("g" racket-profile-refresh) 170 | ("z" racket-profile-show-zero) 171 | ("f" racket-profile-show-non-project) 172 | ("." racket-profile-visit) 173 | ("RET" racket-profile-visit))) 174 | m) 175 | "Keymap for Racket Profile mode.") 176 | 177 | (define-derived-mode racket-profile-mode tabulated-list-mode 178 | "RacketProfile" 179 | "Major mode for results of `racket-profile'. 180 | 181 | \\{racket-profile-mode-map} 182 | " 183 | (setq show-trailing-whitespace nil) 184 | (setq tabulated-list-sort-key '("Calls" . t))) 185 | 186 | (provide 'racket-profile) 187 | 188 | ;; racket-profile.el ends here 189 | -------------------------------------------------------------------------------- /racket-repl-buffer-name.el: -------------------------------------------------------------------------------- 1 | ;;; racket-repl-buffer-name.el -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'racket-back-end) 12 | (require 'racket-custom) 13 | (require 'racket-repl) 14 | (require 'racket-util) 15 | (require 'tramp) 16 | 17 | ;;;###autoload 18 | (defun racket-call-racket-repl-buffer-name-function () 19 | "Unless it already has a value, set the buffer-local value of 20 | the variable `racket-repl-buffer-name' according to the user's 21 | customization." 22 | (unless racket-repl-buffer-name ;#655 23 | (funcall (or (and (functionp racket-repl-buffer-name-function) 24 | racket-repl-buffer-name-function) 25 | #'racket-repl-buffer-name-shared)))) 26 | 27 | ;;;###autoload 28 | (defun racket-repl-buffer-name-shared () 29 | "Share one `racket-repl-mode' buffer per back end. 30 | 31 | A value for the variable `racket-repl-buffer-name-function'." 32 | (interactive) 33 | (setq-local racket-repl-buffer-name 34 | (format "*Racket REPL <%s>*" 35 | (racket-back-end-name)))) 36 | 37 | ;;;###autoload 38 | (defun racket-repl-buffer-name-unique () 39 | "Each `racket-mode' edit buffer gets its own `racket-repl-mode' buffer. 40 | 41 | A value for the variable `racket-repl-buffer-name-function'." 42 | (interactive) 43 | (let ((name (format "*Racket REPL <%s>*" (racket--buffer-file-name)))) 44 | (setq-local racket-repl-buffer-name name))) 45 | 46 | ;;;###autoload 47 | (defun racket-repl-buffer-name-project () 48 | "Share one `racket-repl-mode' buffer per back end and per project. 49 | 50 | A value for the variable `racket-repl-buffer-name-function'. 51 | 52 | The \"project\" is determined by `racket-project-root'." 53 | (interactive) 54 | (setq-local racket-repl-buffer-name 55 | (format "*Racket REPL <%s %s>*" 56 | (racket-back-end-name) 57 | (racket--file-name-sans-remote-method 58 | (racket-project-root (racket--buffer-file-name)))))) 59 | 60 | (defun racket-mode-maybe-offer-to-kill-repl-buffer () 61 | "Maybe offer to kill a `racket-repl-mode' buffer. 62 | 63 | Intended to be a buffer-local value for `kill-buffer-hook' in 64 | `racket-mode' or `racket-hash-lang-mode' edit buffers. 65 | 66 | Offer to kill an `racket-repl-mode' buffer when killing the last 67 | edit buffer using it. Although is not necessary to do so, a user 68 | might want to do some \"cleanup\" -- especially if they're using 69 | a `racket-repl-buffer-name-function' such as 70 | `racket-repl-buffer-name-unique'." 71 | (when (racket--edit-mode-p) 72 | (pcase (get-buffer racket-repl-buffer-name) 73 | ((and (pred bufferp) (pred buffer-live-p) repl-buffer) 74 | (let ((n (1- 75 | (length 76 | (racket--edit-buffers-using-repl racket-repl-buffer-name))))) 77 | (if (zerop n) 78 | (when (y-or-n-p 79 | (format "No other buffers using %s -- also kill it? " 80 | racket-repl-buffer-name)) 81 | (kill-buffer repl-buffer)) 82 | (message "%s other buffer%s still using %s" 83 | n 84 | (if (= n 1) "" "s") 85 | racket-repl-buffer-name))))))) 86 | 87 | (defun racket--edit-buffers-using-repl (repl-buffer-name) 88 | (seq-filter (lambda (buffer) 89 | (with-current-buffer buffer 90 | (and (racket--edit-mode-p) 91 | (equal racket-repl-buffer-name repl-buffer-name)))) 92 | (buffer-list))) 93 | 94 | (provide 'racket-repl-buffer-name) 95 | 96 | ;; racket-repl-buffer-name.el ends here 97 | -------------------------------------------------------------------------------- /racket-scribble-anchor.el: -------------------------------------------------------------------------------- 1 | ;;; racket-scribble-anchor.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2022-2024 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'cl-macs) 12 | (require 'ring) 13 | (require 'seq) 14 | (require 'shr) 15 | (require 'racket-back-end) 16 | (require 'racket-describe) 17 | (require 'racket-scribble) 18 | 19 | (defun racket--company-doc-buffer (how str) 20 | (pcase (racket--cmd/await (racket--repl-session-id) 21 | `(describe ,(racket-how-front-to-back how) ,str)) 22 | (`(,(and path (pred stringp)) . ,anchor) 23 | (let ((path (racket-file-name-back-to-front path)) 24 | (name "*racket-company-doc-buffer*")) 25 | (when-let (buf (get-buffer name)) 26 | (when (buffer-live-p buf) 27 | (kill-buffer buf))) 28 | (with-current-buffer (get-buffer-create name) 29 | (goto-char (point-min)) 30 | (racket--scribble-path+anchor-insert path anchor) 31 | (goto-char (point-min)) 32 | (setq buffer-read-only t) 33 | (current-buffer)))))) 34 | 35 | (defvar racket--path+anchor-ring (make-ring 16) 36 | "A small MRU cache of the N most recent strings. 37 | Each ring item is (cons (cons path anchor) str).") 38 | 39 | (defun racket--path+anchor->string (path anchor) 40 | "A wrapper for `racket--scribble-path+anchor-insert'. 41 | Uses `racket--path+anchor-cache'." 42 | (pcase (seq-some (lambda (item) 43 | (and (equal (car item) (cons path anchor)) 44 | item)) 45 | (ring-elements racket--path+anchor-ring)) 46 | ((and `(,_path+anchor . ,str) item) 47 | ;; Re-insert as newest. 48 | (ring-remove+insert+extend racket--path+anchor-ring item) 49 | str) 50 | (_ 51 | (let* ((str (with-temp-buffer 52 | (racket--scribble-path+anchor-insert path anchor) 53 | (buffer-string))) 54 | (item (cons (cons path anchor) str))) 55 | ;; Insert as newest; oldest discarded when ring full. 56 | (ring-insert racket--path+anchor-ring item) 57 | str)))) 58 | 59 | (defun racket--scribble-path+anchor-insert (path anchor) 60 | (let* ((tramp-verbose 2) ;avoid excessive tramp messages 61 | (dom (racket--html-file->dom path)) 62 | (dom (racket--elements-for-anchor dom anchor)) 63 | (dom (racket--massage-scribble-dom path 64 | (file-name-directory path) 65 | dom))) 66 | (ignore tramp-verbose) 67 | (save-excursion 68 | (let ((shr-use-fonts nil) 69 | (shr-external-rendering-functions `((span . ,#'racket-render-tag-span))) 70 | (shr-width 76)) 71 | (shr-insert-document dom))) 72 | (while (re-search-forward (string racket--scribble-temp-nbsp) nil t) 73 | (replace-match " " t t)))) 74 | 75 | (defun racket--elements-for-anchor (dom anchor) 76 | "Return the subset of DOM elements pertaining to ANCHOR." 77 | (cl-flet 78 | ((anchor-p (node name) 79 | (dom-search node 80 | (lambda (node) 81 | (and (eq 'a (dom-tag node)) 82 | (equal name (dom-attr node 'name)))))) 83 | (boxed-p (node) 84 | (dom-search node 85 | (lambda (node) 86 | (and (eq 'table (dom-tag node)) 87 | (equal "boxed RBoxed" (dom-attr node 'class)))))) 88 | (heading-p (node) 89 | (memq (dom-tag node) '(h1 h2 h3 h4 h5 h6)))) 90 | ;; Consider immediate children of the "main" div. 91 | (let ((result nil) 92 | (xs (dom-children 93 | (dom-search (dom-child-by-tag dom 'body) 94 | (lambda (node) 95 | (and (eq 'div (dom-tag node)) 96 | (equal "main" (dom-attr node 'class)))))))) 97 | ;; Discard elements before the one containing a matching anchor. 98 | (while (and xs (not (anchor-p (car xs) anchor))) 99 | (setq xs (cdr xs))) 100 | ;; Accumulate result up to an element containing an RBoxed table 101 | ;; or heading. 102 | (when xs 103 | (push (car xs) result) 104 | (setq xs (cdr xs)) 105 | (while (and xs (not (or (heading-p (car xs)) 106 | (boxed-p (car xs))))) 107 | (push (car xs) result) 108 | (setq xs (cdr xs)))) 109 | `(div () ,@(reverse result))))) 110 | 111 | (provide 'racket-scribble-anchor) 112 | 113 | ;; racket-scribble-anchor.el ends here 114 | -------------------------------------------------------------------------------- /racket-shell.el: -------------------------------------------------------------------------------- 1 | ;;; racket-shell.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2022 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'racket-custom) 12 | (require 'racket-util) 13 | (require 'shell) 14 | (require 'subr-x) 15 | (require 'term) 16 | 17 | (defun racket-racket () 18 | "Use command-line racket to run the file. 19 | 20 | Uses a shell or terminal buffer as specified by the configuration 21 | variable `racket-shell-or-terminal-function'." 22 | (interactive) 23 | (racket--shell-or-terminal 24 | (concat (shell-quote-argument (racket--buffer-file-name))))) 25 | 26 | (defun racket-raco-test () 27 | "Use command-line raco test to run the \"test\" submodule. 28 | 29 | Uses a shell or terminal buffer as specified by the configuration 30 | variable `racket-shell-or-terminal-function'." 31 | (interactive) 32 | (racket--shell-or-terminal 33 | (concat "-l raco test -x " 34 | (shell-quote-argument (racket--buffer-file-name))))) 35 | 36 | (defun racket--shell-or-terminal (args) 37 | (racket--save-if-changed) 38 | (let* ((command (if (stringp racket-program) 39 | (list racket-program) 40 | racket-program)) 41 | (program (car command)) 42 | (exe (shell-quote-argument 43 | (if (file-name-absolute-p program) 44 | (expand-file-name program) ;handle e.g. ~/ 45 | program))) 46 | (flags (mapcar (lambda (x) (shell-quote-argument x)) 47 | (cdr command))) 48 | (cmd (concat exe " " (string-join flags " ") args)) 49 | (win (selected-window))) 50 | (funcall racket-shell-or-terminal-function cmd) 51 | (select-window win))) 52 | 53 | (defun racket-shell (cmd) 54 | "Run CMD using `shell'. 55 | 56 | A value for the variable `racket-shell-or-terminal-function'." 57 | (let ((buf (shell))) 58 | (comint-simple-send buf cmd))) 59 | 60 | (defun racket-term (cmd) 61 | "Run CMD using `term'. 62 | 63 | A value for the variable `racket-shell-or-terminal-function'." 64 | (let ((buf (term (or explicit-shell-file-name 65 | (getenv "ESHELL") 66 | (getenv "SHELL") 67 | "/bin/sh")))) 68 | (term-simple-send buf cmd))) 69 | 70 | (defun racket-ansi-term (cmd) 71 | "Run CMD using `ansi-term'. 72 | 73 | A value for the variable `racket-shell-or-terminal-function'." 74 | (let ((buf (ansi-term (or explicit-shell-file-name 75 | (getenv "ESHELL") 76 | (getenv "SHELL") 77 | "/bin/sh")))) 78 | (term-simple-send buf cmd))) 79 | 80 | (declare-function vterm "ext:vterm") 81 | (declare-function vterm-send-return "ext:vterm") 82 | (declare-function vterm-send-string "ext:vterm") 83 | 84 | (defun racket-vterm (cmd) 85 | "Run CMD using `vterm', if that package is installed. 86 | 87 | A value for the variable `racket-shell-or-terminal-function'." 88 | (unless (require 'vterm nil 'noerror) 89 | (error "Package 'vterm' is not available")) 90 | (vterm) 91 | (vterm-send-string cmd) 92 | (vterm-send-return)) 93 | 94 | (provide 'racket-shell) 95 | 96 | ;; racket-shell.el ends here 97 | -------------------------------------------------------------------------------- /racket-visit.el: -------------------------------------------------------------------------------- 1 | ;;; racket-visit.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2013-2020 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'simple) 12 | (require 'xref) 13 | (require 'racket-complete) 14 | 15 | (defun racket--module-path-name-at-point () 16 | "Treat point as a Racket module path name, possibly in a multi-in form. 17 | 18 | The returned string has text properties: 19 | 20 | - A \"racket-module-path\" property whose value is either 21 | \"absolute\" or \"relative\". 22 | 23 | - The original properties from the buffer. However if a multi-in 24 | form, these are only the properties from the suffix, e.g. the 25 | \"base\" in \"(multi-in racket (base))\", and they are only 26 | applied only to that portion of the returned string, e.g. the 27 | \"base\" portion of \"racket/base\". 28 | 29 | - Regardless of the preceding point, the original 30 | \"racket-xp-def\" property if any from the buffer is applied to 31 | the ENTIRE returned string. That way the caller can simply use 32 | an index of 0 for `get-text-property'." 33 | (when (racket--in-require-form-p) 34 | (save-excursion 35 | (condition-case _ 36 | (progn 37 | (forward-sexp 1) 38 | (backward-sexp 1) 39 | (when (eq ?\" (char-syntax (char-before))) 40 | (backward-char)) 41 | (let ((str (thing-at-point 'sexp))) 42 | (pcase (read str) 43 | ((and (pred identity) sexp) 44 | (let* ((relative-p (stringp sexp)) 45 | (multi-in-prefix 46 | (condition-case _ 47 | (progn 48 | (backward-up-list 1) 49 | (backward-sexp 2) 50 | (when (looking-at-p "multi-in") 51 | (forward-sexp 2) 52 | (backward-sexp 1) 53 | (when (eq ?\" (char-syntax (char-before))) 54 | (backward-char)) 55 | (let* ((v (read (thing-at-point 'sexp t)))) 56 | (unless (equal relative-p (stringp v)) 57 | (user-error "multi-in mixes absolute and relative paths")) 58 | (format "%s/" v)))) 59 | (scan-error nil)))) 60 | (propertize (concat multi-in-prefix str) 61 | 'racket-module-path 62 | (if relative-p 'relative 'absolute) 63 | 'racket-xp-def 64 | (get-text-property 0 'racket-xp-def str))))))) 65 | (scan-error nil))))) 66 | 67 | (defun racket--rkt-or-ss-path (path) 68 | "Handle the situation of #575 where .rkt doesn't exist but .ss does." 69 | (if (file-exists-p path) 70 | path 71 | (let ((other-path (concat (file-name-sans-extension path) 72 | (pcase (file-name-extension path) 73 | ("rkt" ".ss") 74 | ("ss" ".rkt"))))) 75 | (if (file-exists-p other-path) 76 | other-path 77 | path)))) 78 | 79 | (defun racket--pop-to-xref-location (item) 80 | "Similar to the private function `xref--pop-to-location'. 81 | 82 | But not using that, and not using other private functions in its 83 | implementation." 84 | (xref-push-marker-stack) 85 | (let* ((marker (save-excursion 86 | (xref-location-marker (xref-item-location item)))) 87 | (buf (marker-buffer marker))) 88 | (switch-to-buffer buf) 89 | ;; Like (`xref--goto-char' marker) 90 | (unless (and (<= (point-min) marker) (<= marker (point-max))) 91 | (if widen-automatically 92 | (widen) 93 | (user-error "Position is outside accessible part of buffer"))) 94 | (goto-char marker))) 95 | 96 | (define-obsolete-function-alias 'racket-visit-module 97 | 'xref-find-definitions "2020-11-10") 98 | (define-obsolete-function-alias 'racket-visit-definition 99 | 'xref-find-definitions "2020-11-10") 100 | (define-obsolete-function-alias 'racket-xp-visit-definition 101 | 'xref-find-definitions "2020-11-10") 102 | (define-obsolete-function-alias 'racket-repl-visit-definition 103 | 'xref-find-definitions "2020-11-10") 104 | (define-obsolete-function-alias 'racket-unvisit 105 | 'xref-pop-marker-stack "2020-11-10") 106 | 107 | (provide 'racket-visit) 108 | 109 | ;; racket-visit.el ends here 110 | -------------------------------------------------------------------------------- /racket-wsl.el: -------------------------------------------------------------------------------- 1 | ;;; racket-wsl.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2020-2022 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (defvar racket--wslpath (and (eq system-type 'gnu/linux) 12 | (executable-find "wslpath"))) 13 | 14 | (defun racket--call-wsl-path (pathname flag) 15 | "Wrapper for wslpath. 16 | 17 | When variable `racket--wslpath' is not nil, use it to convert 18 | PATHNAME using FLAG. 19 | 20 | wslpath usage: 21 | -a force result to absolute path format 22 | -u translate from a Windows path to a WSL path (default) 23 | -w translate from a WSL path to a Windows path 24 | -m translate from a WSL path to a Windows path, with \"/\" instead of \"\\\" 25 | " 26 | (if racket--wslpath 27 | (with-temp-buffer 28 | (let ((code (call-process racket--wslpath 29 | nil ;infile 30 | (list (current-buffer) ;output 31 | nil) ;stderr 32 | nil ;display 33 | flag 34 | pathname))) 35 | (unless (zerop code) 36 | (error "%s %s %s exit code %s" racket--wslpath flag pathname code))) 37 | (buffer-substring-no-properties (point-min) (1- (point-max)))) 38 | pathname)) 39 | 40 | (defun racket-wsl-to-windows (pathname) 41 | (racket--call-wsl-path pathname "-w")) 42 | 43 | (defun racket-windows-to-wsl (pathname) 44 | (racket--call-wsl-path pathname "-u")) 45 | 46 | (provide 'racket-wsl) 47 | 48 | ;; racket-wsl.el ends here 49 | -------------------------------------------------------------------------------- /racket-xp-complete.el: -------------------------------------------------------------------------------- 1 | ;;; racket-xp-complete.el -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 4 | ;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc. 5 | 6 | ;; Author: Greg Hendershott 7 | ;; URL: https://github.com/greghendershott/racket-mode 8 | 9 | ;; SPDX-License-Identifier: GPL-3.0-or-later 10 | 11 | (require 'seq) 12 | (require 'racket-complete) 13 | (require 'racket-describe) 14 | (require 'racket-scribble-anchor) 15 | 16 | (defvar-local racket--xp-completion-table-all nil 17 | "A completion table of all bindings; for use by a CAPF. 18 | 19 | Includes both imports and lexical bindings. Better for use by 20 | `completion-at-point' in an edit buffer, because in general more 21 | completion candidates offer more opportunities to minimize 22 | typing. 23 | 24 | The table includes category and affixation-function metadata; the 25 | latter shows the module from which an identifier was imported, 26 | when not a lexical binding.") 27 | 28 | (defvar-local racket--xp-completion-table-imports nil 29 | "A completion table of import bindings; for use in minibuffer. 30 | 31 | Includes only imports, not lexical bindings. Definitely better 32 | for use by commands that look up documentation. Sometimes better 33 | for use by `completing-read' in the minibuffer, because that 34 | returns strings stripped of all text properties -- unless a 35 | command is able to find a suitable matching string in the buffer 36 | and use its text properties. 37 | 38 | The table includes category and affixation-function metadata.") 39 | 40 | (defun racket--set-xp-binding-completions (mods+syms) 41 | ;; The back end gives us data optimized for space when serializing: 42 | ;; 43 | ;; ((modA symA0 symA1 ...) 44 | ;; (modB symB0 symB1 ...) ...) 45 | ;; 46 | ;; Reshape that to a list of strings, each propertized with its mod, 47 | ;; for use as completion table. 48 | (let* ((all nil) 49 | (imports nil) 50 | (affixator (racket--make-affix [16 0])) 51 | (metadata `((category . ,racket--identifier-category) 52 | (affixation-function . ,affixator)))) 53 | (dolist (mod+syms mods+syms) 54 | (pcase-let ((`(,mod . ,syms) mod+syms)) 55 | (dolist (sym syms) 56 | (push (propertize sym 'racket-affix (list mod)) all) 57 | (when mod 58 | (push (propertize sym 'racket-affix (list mod)) imports))))) 59 | (setq racket--xp-completion-table-all 60 | (racket--completion-table all metadata)) 61 | (setq racket--xp-completion-table-imports 62 | (racket--completion-table imports metadata)))) 63 | 64 | (defvar-local racket--xp-module-completions nil 65 | "A completion table for available collection module paths. 66 | Do not `setq' directly; instead call `racket--xp-set-module-completions'.") 67 | 68 | (defun racket--set-xp-module-completions (completions) 69 | (setq-local racket--xp-module-completions 70 | (racket--completion-table completions 71 | `((category . ,racket--module-category))))) 72 | 73 | (defun racket-xp-complete-at-point () 74 | "A value for the variable `completion-at-point-functions'. 75 | 76 | - Within a textually apparent \"require\" form, when completing: 77 | 78 | - A symbol immediately after an opening paren: Candidates are 79 | names of require transformers. 80 | 81 | - Another symbol: Candidates are absolute module paths like 82 | \"racket/path\". 83 | 84 | - Anything `thing-at-point' thinks is a filename: Candidates 85 | are from `completion-file-name-table'. 86 | 87 | - Otherwise, when completing a symbol: Candidates are bindings as 88 | found by drracket/check-syntax plus our own back end analysis 89 | of imported bindings." 90 | (if (racket--in-require-form-p) 91 | (or (racket--call-with-completion-prefix-positions 92 | (lambda (beg end) 93 | (if (eq ?\( (char-syntax (char-before beg))) 94 | (racket--xp-capf-require-transformers beg end) 95 | (racket--xp-capf-absolute-module-paths beg end)))) 96 | (racket--xp-capf-relative-module-paths)) 97 | (racket--call-with-completion-prefix-positions 98 | #'racket--xp-capf-bindings))) 99 | 100 | (defun racket--xp-capf-bindings (beg end) 101 | (list beg 102 | end 103 | racket--xp-completion-table-all 104 | ;; ^table metadata already has :affixation-function 105 | :exclusive 'no 106 | :company-location (racket--xp-make-company-location-proc) 107 | :company-doc-buffer (racket--xp-make-company-doc-buffer-proc))) 108 | 109 | (defun racket--xp-capf-require-transformers (beg end) 110 | "Note: Currently this returns too many candidates -- all 111 | available bindings, not just those that are require transformers. 112 | Although not ideal, I think it's less-worse than having some 113 | hardwired list of require transformers. In general with 114 | completion candidates, if you have to err, better to err on the 115 | side of too many not too few. Having said that, someday maybe our 116 | back end could give us the exact subset of available bindings 117 | that are require transformers." 118 | (racket--xp-capf-bindings beg end)) 119 | 120 | (defun racket--xp-capf-absolute-module-paths (beg end) 121 | (list beg 122 | end 123 | racket--xp-module-completions 124 | :exclusive 'no)) 125 | 126 | (defun racket--xp-capf-relative-module-paths () 127 | (when-let (bounds (bounds-of-thing-at-point 'filename)) 128 | (list (car bounds) 129 | (cdr bounds) 130 | #'completion-file-name-table 131 | :exclusive 'no))) 132 | 133 | (defun racket--xp-make-company-location-proc () 134 | (when (racket--cmd-open-p) 135 | (let ((how (racket-how-front-to-back (buffer-file-name)))) 136 | (lambda (str) 137 | (let ((str (substring-no-properties str))) 138 | (pcase (racket--cmd/await nil `(def ,how ,str)) 139 | (`(,path ,line ,_) 140 | (cons (racket-file-name-back-to-front path) line)))))))) 141 | 142 | (defun racket--xp-make-company-doc-buffer-proc () 143 | (when (racket--cmd-open-p) 144 | (let ((how (racket-how-front-to-back (buffer-file-name)))) 145 | (lambda (str) 146 | (let ((str (substring-no-properties str))) 147 | (racket--company-doc-buffer how str)))))) 148 | 149 | (provide 'racket-xp-complete) 150 | 151 | ;; racket-xp-complete.el ends here 152 | -------------------------------------------------------------------------------- /racket/commands/describe.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/contract 7 | racket/format 8 | racket/match 9 | racket/port 10 | (only-in "../find.rkt" find-signature) 11 | "../identifier.rkt" 12 | (only-in "../scribble.rkt" 13 | identifier->bluebox 14 | binding->path+anchor)) 15 | 16 | (provide type 17 | describe) 18 | 19 | (module+ test 20 | (require rackunit)) 21 | 22 | ;;; type 23 | 24 | (define/contract (type how str) 25 | (-> how/c string? (or/c #f string?)) 26 | (or (and (eq? how 'namespace) 27 | (->identifier 'namespace str type-or-contract)) 28 | (->identifier how str identifier->bluebox) 29 | (match (find-signature how str) 30 | [#f #f] 31 | [x (~a x)]))) 32 | 33 | (define (type-or-contract v) ;any/c -> (or/c #f string?) 34 | (or 35 | ;; 1. Try using Typed Racket's REPL simplified type. 36 | (with-handlers ([exn:fail? (λ _ #f)]) 37 | (match (with-output-to-string 38 | (λ () 39 | ((current-eval) 40 | (cons '#%top-interaction v)))) 41 | [(pregexp "^- : (.*) \\.\\.\\..*\n" (list _ t)) t] 42 | [(pregexp "^- : (.*)\n$" (list _ t)) t])) 43 | ;; 2. Try to find a contract. 44 | (with-handlers ([exn:fail? (λ _ #f)]) 45 | (parameterize ([error-display-handler (λ _ (void))]) 46 | ((current-eval) 47 | (cons '#%top-interaction 48 | `(if (has-contract? ,v) 49 | (~a (contract-name (value-contract ,v))) 50 | (error "")))))))) 51 | 52 | ;;; describe 53 | 54 | ;; When `str` is an identifier for which we can find documentation, 55 | ;; return (cons path anchor). 56 | ;; 57 | ;; Otherwise, try to find a function definition signature (the 58 | ;; argument names may have explanatory value), and/or a Typed Racket 59 | ;; type or a contract, if any. If found return (list 'shr-dom dom) 60 | ;; where dom is the Emacs equivalent of an x-expression. 61 | ;; 62 | ;; Otherwise return #f. 63 | (define/contract (describe how str) 64 | (-> how/c 65 | string? 66 | any) ;(or/c #f (cons/c path-string? string?) shr-dom) 67 | (->identifier 68 | how str 69 | (λ (stx) 70 | (or (binding->path+anchor stx) 71 | (sig-and/or-type how stx))))) 72 | 73 | (define/contract (sig-and/or-type how stx) 74 | (-> how/c identifier? any) ;shr-dom 75 | (define dat (syntax->datum stx)) 76 | (define sig (match (find-signature how (symbol->string dat)) 77 | [#f #f] 78 | [x (~a x)])) 79 | (define type (and (eq? how 'namespace) 80 | (type-or-contract stx))) 81 | (define in (if (eq? how 'namespace) "current-namespace" (~v how))) 82 | (and (or sig type) 83 | (list 'shr-dom 84 | `(div () 85 | (h1 () (code () ,(or sig (~a dat)))) 86 | (p () ,(if type `(code () ,type) "")) 87 | (p () "In " (code () ,in) "."))))) 88 | 89 | (module+ test 90 | (require rackunit 91 | "../syntax.rkt") 92 | ;; Check something that is in the namespace resulting from 93 | ;; module->namespace on, say, this source file. 94 | (parameterize ([current-namespace (module->namespace (syntax-source #'this-file))]) 95 | (check-equal? 96 | (describe 'namespace "describe") 97 | '(shr-dom 98 | (div 99 | () 100 | (h1 () (code () "(describe how str)")) 101 | (p () (code () "(-> (or/c (quote namespace) path-string?) string? any)")) 102 | (p () "In " (code () "current-namespace") ".")))) 103 | (check-false 104 | (describe 'namespace "something-not-defined-in-the-namespace"))) 105 | 106 | ;; Check something that is not in the current namespace, but is an 107 | ;; identifier in the lexical context of an expanded module form -- 108 | ;; including imported identifiers -- from the expanded syntax 109 | ;; cache. 110 | (define top (case (system-type) [(windows) "C:\\"] [(unix macosx) "/"])) 111 | (define path-str (path->string (build-path top "path" "to" "foobar.rkt"))) 112 | (define code-str (~a '(module foobar racket/base 113 | (define (fun a b c) 114 | (void))))) 115 | ;; Get the expanded syntax in our cache 116 | (string->expanded-syntax path-str code-str void) 117 | ;; Note that this doesn't find contracts, just sigs. 118 | (check-equal? 119 | (describe path-str "fun") 120 | `(shr-dom 121 | (div () 122 | (h1 () (code () "(fun a b c)")) 123 | (p () "") 124 | (p () "In " (code () ,(~v path-str)) ".")))) 125 | (check-false 126 | (describe path-str "something-not-defined-in-the-file"))) 127 | 128 | -------------------------------------------------------------------------------- /racket/commands/find-module.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/contract 7 | racket/match 8 | racket/path 9 | syntax/modresolve 10 | "../repl.rkt") 11 | 12 | (provide find-module) 13 | 14 | (define/contract (find-module str maybe-mod) 15 | (-> string? (or/c #f module-path?) 16 | (or/c #f (list/c path-string? number? number?))) 17 | (define file (maybe-module-path->file maybe-mod)) 18 | (parameterize ([current-load-relative-directory (path-only file)]) 19 | (or (mod-loc str maybe-mod) 20 | (mod-loc (string->symbol str) maybe-mod)))) 21 | 22 | (define (mod-loc v maybe-rmp) 23 | (match (with-handlers ([exn:fail? (λ _ #f)]) 24 | (resolve-module-path v maybe-rmp)) 25 | [(? path-string? path) 26 | #:when (file-exists? path) 27 | (list (path->string path) 1 0)] 28 | [_ #f])) 29 | 30 | (module+ test 31 | (require rackunit 32 | racket/runtime-path) 33 | (define-runtime-path here ".") 34 | (let* ([here (simplify-path here)] ;nuke trailing dot 35 | ;; Examples of finding relative and absolute: 36 | [requires.rkt (path->string (build-path here "requires.rkt"))] 37 | [pe-racket/string (pregexp "collects/racket/string.rkt$")]) 38 | ;; Examples of having no current module (i.e. plain racket/base 39 | ;; REPL) and having one ("describe.rkt"). 40 | (let ([mod #f]) 41 | (parameterize ([current-directory here]) 42 | (check-match (find-module "requires.rkt" mod) 43 | (list (== requires.rkt) 1 0)) 44 | (check-match (find-module "racket/string" mod) 45 | (list pe-racket/string 1 0)))) 46 | (let ([mod (build-path here "describe.rkt")]) 47 | (check-match (find-module "requires.rkt" mod) 48 | (list (== requires.rkt) 1 0)) 49 | (check-match (find-module "racket/string" mod) 50 | (list pe-racket/string 1 0))))) 51 | -------------------------------------------------------------------------------- /racket/commands/help.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang at-exp racket/base 5 | 6 | (require (only-in scribble/core tag?) 7 | scribble/xref 8 | racket/contract 9 | racket/format 10 | racket/match 11 | "../identifier.rkt" 12 | "../xref.rkt") 13 | 14 | (provide doc) 15 | 16 | ;; Once upon a time, you could enter commands in the REPL like ",doc". 17 | ;; It made sense to open the browser here -- despite needing junk to 18 | ;; convince macOS to open a file: URL using anchors a.k.a. fragments. 19 | ;; 20 | ;; But nowadays? Just return the URL. Let Emacs open the browser. 21 | ;; Especially because now check-syntax sometimes returns a help URL, 22 | ;; in which case the front end should just open the browser. Given 23 | ;; that case, let's always open the browser one consistent way -- in 24 | ;; Emacs using browse-url. 25 | 26 | (define/contract (doc how str) 27 | (-> how/c string? (or/c #f string?)) 28 | (->identifier how str stx->uri-string)) 29 | 30 | (define (stx->uri-string stx) 31 | (define xref (get-xref)) 32 | (match (and xref (xref-binding->definition-tag xref stx 0)) 33 | [(? tag? tag) 34 | (define-values (path anchor) (xref-tag->path+anchor xref tag)) 35 | (~a "file://" path "#" anchor)] 36 | [_ #f])) 37 | -------------------------------------------------------------------------------- /racket/commands/macro.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require (only-in macro-debugger/stepper-text 7 | stepper-text) 8 | (only-in macro-debugger/model/hiding-policies 9 | policy->predicate) 10 | racket/contract 11 | racket/file 12 | racket/format 13 | racket/match 14 | (only-in racket/path 15 | path-only) 16 | racket/pretty 17 | racket/system 18 | "../elisp.rkt" 19 | "../repl-session.rkt" 20 | "../syntax.rkt" 21 | "../util.rkt") 22 | 23 | (provide macro-stepper 24 | macro-stepper/next) 25 | 26 | (define step/c (cons/c (or/c 'original string? 'final) string?)) 27 | (define step-proc/c (-> (or/c 'next 'all) (listof step/c))) 28 | 29 | (define (nothing-step-proc _) null) 30 | 31 | (define step-proc nothing-step-proc) 32 | 33 | (define/contract (macro-stepper path expression-str hiding-policy) 34 | (-> (and/c path-string? complete-path?) any/c any/c 35 | (list/c step/c)) 36 | (assert-macro-debugger-stepper-works) 37 | (define-values (stx ns) 38 | (cond 39 | [(string? expression-str) 40 | (unless (current-session-id) 41 | (error 'macro-stepper "Does not work without a running REPL")) 42 | (values (string->namespace-syntax expression-str) 43 | (current-namespace))] 44 | [else 45 | (values (file->syntax path) 46 | (make-base-namespace))])) 47 | (set! step-proc 48 | (make-stepper path stx ns hiding-policy)) 49 | (macro-stepper/next 'next)) 50 | 51 | (define/contract (macro-stepper/next what) step-proc/c 52 | (define v (step-proc what)) 53 | (match v 54 | [(list (cons 'final _)) (set! step-proc nothing-step-proc)] 55 | [_ (void)]) 56 | v) 57 | 58 | (define/contract (make-stepper path stx ns elisp-hiding-policy) 59 | (-> (and/c path-string? complete-path?) syntax? namespace? any/c 60 | step-proc/c) 61 | (define dir (path-only path)) 62 | (define policy (elisp-policy->policy elisp-hiding-policy)) 63 | (define predicate (policy->predicate policy)) 64 | (define raw-step (parameterize ([current-load-relative-directory dir] 65 | [current-namespace ns]) 66 | (stepper-text stx predicate))) 67 | (define step-num #f) 68 | (define step-last-after (pretty-format-syntax stx)) 69 | (log-racket-mode-debug "~v ~v ~v" path policy raw-step) 70 | (define/contract (step what) step-proc/c 71 | (cond [(not step-num) 72 | (set! step-num 0) 73 | (list (cons 'original 74 | (pretty-format-syntax stx)))] 75 | [else 76 | (define out (open-output-string)) 77 | (cond [(parameterize ([current-output-port out]) 78 | (raw-step what)) 79 | (log-racket-mode-debug "~v" (get-output-string out)) 80 | (define in (open-input-string (get-output-string out))) 81 | (let loop () 82 | (match (parameterize ([current-input-port in]) 83 | (read-step)) 84 | [(? eof-object?) 85 | (cond [(eq? what 'all) 86 | (list (cons 'final step-last-after))] 87 | [else (list)])] 88 | [(list title before after) 89 | (set! step-num (add1 step-num)) 90 | (set! step-last-after after) 91 | (cons (cons (~a step-num ": " title) 92 | (diff-text before after #:unified 3)) 93 | (loop))]))] 94 | [else 95 | (list (cons 'final step-last-after))])])) 96 | step) 97 | 98 | (define (elisp-policy->policy e) 99 | ;; See macro-debugger/model/hiding-policies.rkt): 100 | ;; 101 | ;; A Policy is one of 102 | ;; 'disable 103 | ;; 'standard 104 | ;; (list 'custom boolean boolean boolean boolean (listof Entry)) 105 | ;; 106 | ;; Of the Entry rules, although the free=? one can't work because it 107 | ;; needs a live syntax object identifier, I think most of the rest 108 | ;; should be fine. 109 | (match e 110 | [(or 'disable 'standard) e] 111 | [(list (app as-racket-bool hide-racket?) 112 | (app as-racket-bool hide-libs?) 113 | (app as-racket-bool hide-contracts?) 114 | (app as-racket-bool hide-phase1?) 115 | rules) 116 | (list 'custom hide-racket? hide-libs? hide-contracts? hide-phase1? rules)])) 117 | 118 | (define (read-step) 119 | (define title (read-line)) 120 | (define before (read)) 121 | (define _arrow (read)) ; '==> 122 | (define after (read)) 123 | (read-line) 124 | (match (read-line) 125 | [(? eof-object? e) e] 126 | [_ (list title 127 | (pretty-format #:mode 'write before) 128 | (pretty-format #:mode 'write after))])) 129 | 130 | (define (diff-text before-text after-text #:unified [-U 3]) 131 | (define template "racket-mode-syntax-diff-~a") 132 | (define (make-temporary-file-with-text str) 133 | (define file (make-temporary-file template)) 134 | (with-output-to-file file #:mode 'text #:exists 'replace 135 | (λ () (displayln str))) 136 | file) 137 | (define before-file (make-temporary-file-with-text before-text)) 138 | (define after-file (make-temporary-file-with-text after-text)) 139 | (define out (open-output-string)) 140 | (dynamic-wind 141 | void 142 | (λ () 143 | (parameterize ([current-output-port out]) 144 | (system (format "diff -U ~a ~a ~a" -U before-file after-file)) 145 | (match (regexp-replace* #rx"\r\n" ;#598 146 | (get-output-string out) 147 | "\n") 148 | ["" " \n"] 149 | [(pregexp "\n(@@.+@@\n.+)$" (list _ v)) v]))) 150 | (λ () 151 | (delete-file before-file) 152 | (delete-file after-file)))) 153 | 154 | (define (pretty-format-syntax stx) 155 | (pretty-format #:mode 'write (syntax->datum stx))) 156 | 157 | (define (assert-macro-debugger-stepper-works) 158 | (define step (stepper-text #'(module example racket/base 42))) 159 | (unless (step 'next) 160 | (error 'macro-debugger/stepper-text 161 | "does not work in your version of Racket.\nPlease try an older or newer version."))) 162 | -------------------------------------------------------------------------------- /racket/commands/module-names.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/contract 7 | racket/match 8 | racket/path 9 | racket/set 10 | racket/string) 11 | 12 | (provide module-names) 13 | 14 | (struct collection 15 | (maybe-prefix ;(or/c #f string?) when a rktd link entry starts with a string 16 | path) ;path? 17 | #:transparent) 18 | 19 | (define (module-names) 20 | (define results (mutable-set)) 21 | (define main.rkt (string->path "main.rkt")) 22 | (for ([coll (in-set (collections))]) 23 | (define top (collection-path coll)) 24 | (when (safe-directory-exists? top) 25 | (parameterize ([current-directory top]) 26 | (for ([raw-p (in-directory #f use?)]) 27 | (define p (maybe-prefix-path-for-collection coll raw-p)) 28 | (define-values (_base _name dir?) (split-path p)) 29 | (when (and (use? p) 30 | (or dir? 31 | (member (path-get-extension p) '(#".rkt" #".ss")))) 32 | (match-define (cons last-part first-parts) (reverse (explode-path p))) 33 | (define path-parts 34 | (reverse 35 | (cond [;; path/to/main.rkt => path/to 36 | (equal? last-part main.rkt) first-parts] 37 | [;; path/to/file.rkt => path/to/file 38 | else (cons (path-replace-extension last-part #"") 39 | first-parts)]))) 40 | ;; Use string-join with "/" instead of build-path so that 41 | ;; Windows paths become Racket module paths. 42 | (set-add! results (string-join (map path->string path-parts) 43 | "/"))))))) 44 | (sort (set->list results) 45 | stringsymbol m) (void))) 58 | m))) 59 | 60 | (define (use? p) 61 | (define-values (_base name dir?) (split-path p)) 62 | (define name-str (path->string name)) 63 | (and (not (string-prefix? name-str ".")) 64 | (not (member name-str '("compiled" 65 | "doc" 66 | "info.rkt" 67 | "private" 68 | "scribblings" 69 | "tests")))) ) 70 | 71 | (define (collections) 72 | (define results (mutable-set)) 73 | (for ([link-file (in-list (current-library-collection-links))]) 74 | (cond [link-file 75 | (when (file-exists? link-file) 76 | (define-values (base _name _dir?) (split-path link-file)) 77 | (match (with-handlers ([exn:fail? (λ (x) '())]) 78 | (call-with-input-file link-file read)) 79 | [(? list? vs) 80 | (for ([v (in-list vs)]) 81 | (when (if (and (list? v) (= 3 (length v))) 82 | (and (regexp? (list-ref v 2)) 83 | (regexp-match (list-ref v 2) (version))) 84 | #t) 85 | (define prefix (if (string? (list-ref v 0)) 86 | (list-ref v 0) 87 | #f)) 88 | (define path 89 | (match (list-ref v 1) 90 | [(? string? str) str] 91 | [(? bytes? bstr) (bytes->path bstr)] 92 | [(? list? elems) (apply build-path 93 | (for/list ([elem (in-list elems)]) 94 | (if (bytes? elem) 95 | (bytes->path-element elem) 96 | elem)))])) 97 | (define abs-path (simplify-path 98 | (if (relative-path? path) 99 | (build-path base path) 100 | path))) 101 | (set-add! results 102 | (collection prefix 103 | abs-path))))] 104 | [_ (void)]))] 105 | [else 106 | (for ([p (in-list (current-library-collection-paths))]) 107 | (set-add! results (collection #f 108 | (simplify-path p))))])) 109 | results) 110 | 111 | (define (maybe-prefix-path-for-collection coll path) 112 | (if (collection-maybe-prefix coll) 113 | (build-path (collection-maybe-prefix coll) path) 114 | path)) 115 | 116 | (define/contract (safe-directory-exists? d) 117 | (-> path-string? boolean?) 118 | (with-handlers ([exn:fail? (λ (x) #f)]) 119 | (directory-exists? d))) 120 | -------------------------------------------------------------------------------- /racket/define-fallbacks.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2024 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require (for-syntax racket/base 7 | (only-in "safe-dynamic-require.rkt" 8 | safe-dynamic-require)) 9 | syntax/parse/define) 10 | 11 | (provide define-fallbacks) 12 | 13 | ;; safe-dynamic-require is most useful in scenarios where an entire 14 | ;; module might not be installed. Note that tools like 15 | ;; go-to-definition will always go to the safe-dynamic-require site, 16 | ;; because that is the binding site. Any binding from a normal 17 | ;; (non-dynamic) require is shadowed by the dynamic require. 18 | ;; 19 | ;; Another scenario is where a module is always installed, but over 20 | ;; time has added exports; therefore an older version might be 21 | ;; installed. In this case it can be nicer to do a plain, non-dynamic 22 | ;; require of the module, and use define-fallbacks to create 23 | ;; definitions /only/ for identifiers not supplied by the installed 24 | ;; version of the module. As a result, tools like go-to-definition 25 | ;; will handle normally imported bindings in the usual way (go to the 26 | ;; definition in that other module's source), which is very 27 | ;; convenient. 28 | 29 | (define-syntax-parser define-fallback 30 | [(_ mod:id (id:id arg:expr ...) body:expr ...+) 31 | (if (safe-dynamic-require (syntax-e #'mod) (syntax-e #'id)) 32 | #'(begin) 33 | #'(define (id arg ...) 34 | body ...))]) 35 | 36 | (define-syntax-parser define-fallbacks 37 | [(_ mod:id [(id:id arg:expr ...) body:expr ...+] ...+) 38 | #`(begin 39 | (define-fallback mod (id arg ...) body ...) ...)]) 40 | -------------------------------------------------------------------------------- /racket/elisp.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/contract 7 | racket/match 8 | racket/port 9 | racket/set 10 | syntax/parse/define 11 | "safe-dynamic-require.rkt") 12 | 13 | (define number-markup? 14 | (safe-dynamic-require 'simple-tree-text-markup/data 'number-markup? 15 | (λ () (λ _ #f)))) 16 | 17 | (define number-markup-number 18 | (safe-dynamic-require 'simple-tree-text-markup/data 'number-markup-number 19 | (λ () (λ _ 0)))) 20 | 21 | (provide elisp-read 22 | elisp-bool/c 23 | as-racket-bool 24 | with-parens 25 | elisp-write 26 | elisp-writeln) 27 | 28 | ;;; Read a subset of Emacs Lisp values as Racket values 29 | 30 | (define (elisp-read in) 31 | (elisp->racket (read in))) 32 | 33 | (define (elisp->racket v) 34 | (match v 35 | ['nil '()] ;not #f -- see as-racket-bool 36 | ['t #t] 37 | [(? list? xs) (map elisp->racket xs)] 38 | [(cons x y) (cons (elisp->racket x) (elisp->racket y))] 39 | [(vector s _ ...) s] ;Emacs strings can be #("string" . properties) 40 | [v v])) 41 | 42 | (define elisp-bool/c (or/c #t '())) 43 | (define (as-racket-bool v) 44 | ;; elisp->racket "de-puns" 'nil as '() -- not #f. Use this helper when 45 | ;; instead you want to treat it as a boolean and get #f. 46 | (and v (not (null? v)))) 47 | 48 | ;;; Write a subset of Racket values as Emacs Lisp values 49 | 50 | (define (elisp-writeln v) 51 | (elisp-write v) 52 | (newline)) 53 | 54 | (define-simple-macro (with-parens e:expr ...+) 55 | (begin (display "(") 56 | e ... 57 | (display ")"))) 58 | 59 | (define (elisp-write v) 60 | (match v 61 | [(or #f (list)) (write 'nil)] 62 | [#t (write 't)] 63 | [(? list? xs) (with-parens 64 | (for-each (λ (v) 65 | (elisp-write v) 66 | (display " ")) 67 | xs))] 68 | [(cons x y) (with-parens 69 | (elisp-write x) 70 | (display " . ") 71 | (elisp-write y))] 72 | [(? path? v) (elisp-write (path->string v))] 73 | [(? hash? v) (with-parens 74 | (hash-for-each v 75 | (λ (k v) 76 | (elisp-write (cons k v)) 77 | (display " "))))] 78 | [(? generic-set? v) (with-parens 79 | (set-for-each v 80 | (λ (v) 81 | (elisp-write v) 82 | (display " "))))] 83 | [(? void?) (display "void")] ;avoid Elisp-unreadable "#" 84 | [(? procedure? w) (w)] 85 | [(or (? number? v) 86 | (? symbol? v) 87 | (? string? v)) (write v)] 88 | [(? bytes? bstr) (write (bytes->string/utf-8 bstr))] ; ??? 89 | ;; #731: htdp/bsl assumes port-writes-special? means it can write 90 | ;; number-markup structs. It ought not to, but accomodate here. 91 | ;; Note: See gui.rkt for namespace-attach-module of 92 | ;; simple-tree-text-markup/data, necessary because generative 93 | ;; structs. 94 | [(? number-markup? m) (write (number-markup-number m))] 95 | [v (write (format "~s" v))])) 96 | 97 | (module+ test 98 | (require rackunit) 99 | (check-equal? (with-output-to-string 100 | (λ () (elisp-write '(1 #t nil () (a . b) #hash((1 . 2) (3 . 4)))))) 101 | "(1 t nil nil (a . b) ((1 . 2) (3 . 4) ) )")) 102 | -------------------------------------------------------------------------------- /racket/error.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/format 7 | racket/match 8 | "instrument.rkt" 9 | "repl-output.rkt" 10 | "stack-checkpoint.rkt") 11 | 12 | (provide racket-mode-error-display-handler) 13 | 14 | (define default-error-display-handler (error-display-handler)) 15 | 16 | ;; On the one hand, the docs say: "An error display handler can print 17 | ;; errors in different ways, but it should always print to the current 18 | ;; error port." After all, a user program might use 19 | ;; error-display-handler, as in #672. 20 | ;; 21 | ;; On the other hand, we really want to give our front end REPL 22 | ;; /structured/ error data via our special channel, not text. 23 | ;; 24 | ;; I think the solution is to check whether current-error-port is the 25 | ;; special one we use for structured REPL output, a.k.a. the original 26 | ;; value for the user program. 27 | 28 | ;; - If so it's fine to bend the rules and use our special output 29 | ;; channel to the front end. Probably we're the one using the 30 | ;; handler. Even if the user program is, the meaning is "use it 31 | ;; for-effect to output to the original error port", which in this 32 | ;; case means ultimately to the Racket Mode front end REPL. It's OK 33 | ;; and in fact desirable to get the same structured error handling. 34 | ;; 35 | ;; - Otherwise, we're running while the user program has parameterized 36 | ;; current-error-port, perhaps to an output-string to use for-value, 37 | ;; or to some other port to use for-effect. In that case we defer 38 | ;; /completely/ to the default error-display-handler. Not only does 39 | ;; that output to current-error-port, the overall format will be the 40 | ;; same as when the user program is run with command-line racket. 41 | ;; (Of course some context items may differ on the "outside" edge, 42 | ;; showing wx/queue.rkt, racket-mode's repl.rkt, etc. But the 43 | ;; "inner" items and the overall format will be the same.) 44 | (define (racket-mode-error-display-handler msg v) 45 | (cond 46 | [(repl-error-port? (current-error-port)) 47 | (cond 48 | [(exn? v) 49 | (let ([msg (if (member (exn-message v) (list msg "")) 50 | msg 51 | (string-append msg "\n" (exn-message v)))]) 52 | (repl-output-error (list msg (srclocs v) (context v))))] 53 | [else 54 | (displayln msg (current-error-port)) 55 | (flush-output (current-error-port))])] 56 | [else 57 | (default-error-display-handler msg v)])) 58 | 59 | (define (srclocs e) 60 | (cond [(exn:srclocs? e) 61 | (for*/list ([sl (in-list ((exn:srclocs-accessor e) e))] 62 | [elv (in-value (srcloc->elisp-value sl))] 63 | #:when elv) 64 | elv)] 65 | [else null])) 66 | 67 | (define (context e) 68 | (define-values (kind fmt pairs) 69 | (cond [(instrumenting-enabled) 70 | (values 'errortrace 71 | ~s 72 | (get-error-trace e))] 73 | [else 74 | (values 'plain 75 | ~a 76 | (for/list ([_ (error-print-context-length)] 77 | [v (in-list 78 | (continuation-mark-set->trimmed-context 79 | (exn-continuation-marks e)))]) 80 | v))])) 81 | (cons kind 82 | (for/list ([v (in-list pairs)]) 83 | (match-define (cons label src) v) 84 | (cons (and label (fmt label)) 85 | (and src (srcloc->elisp-value src)))))) 86 | 87 | (define (srcloc->elisp-value loc) 88 | (define src 89 | ;; Although I want to find/fix this properly upstream -- is 90 | ;; something a path-string? when it should be a path? -- for now 91 | ;; just catch here the case where the source is a string like 92 | ;; "\"/path/to/file.rkt\"" i.e. the string value has quotes. 93 | (match (srcloc-source loc) 94 | [(pregexp "^\"(.+)\"$" (list _ unquoted)) unquoted] 95 | [(? path? v) (path->string v)] 96 | [v v])) 97 | (define str (or (srcloc->string loc) 98 | (format "~a:~a:~a" src (srcloc-line loc) (srcloc-column loc)))) 99 | (and (path-string? src) 100 | (srcloc-line loc) 101 | (srcloc-column loc) 102 | (srcloc-position loc) 103 | (srcloc-span loc) 104 | (list str src (srcloc-line loc) (srcloc-column loc) (srcloc-position loc) (srcloc-span loc)))) 105 | -------------------------------------------------------------------------------- /racket/find-module-path-completions.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | ;;; `racket-open-require-path' uses `tq' to run us. We repeatedly 7 | ;;; read-line a query and display the answer as lines terminated by a 8 | ;;; blank line. 9 | ;;; 10 | ;;; This was created because the original attempt, using 11 | ;;; `racket--eval/sexpr', couldn't keep up with fast typing. This new 12 | ;;; approach is more direct (e.g. no converting to/from sexprs) and 13 | ;;; fast enough. Using `tq' provides a "type-ahead buffer" (in lieu of 14 | ;;; the old approach's use of `run-with-timer') even though in my 15 | ;;; testing so far it's rarely needed. 16 | ;;; 17 | ;;; The case where `find-module-path-completions' isn't available: We 18 | ;;; don't error, we simply always return empty matches. (This might 19 | ;;; not be ideal but I initially had trouble making `tq' recognize 20 | ;;; e.g. an (exit 1) here and handle it smoothly. Maybe it would work 21 | ;;; to change our "protocol" to have an initial question and answer 22 | ;;; devoted to this. For example "HELLO?\n" => "OK\n\n" / "ERROR\n\n". 23 | ;;; Thereafter the status quo loop.) 24 | 25 | (require "safe-dynamic-require.rkt") 26 | 27 | (module+ main 28 | (define dir (current-directory)) ;FIXME: Get from command-line 29 | (define display-choices (init dir)) 30 | (let loop () 31 | (define str (read-line)) 32 | (unless (string=? "" str) 33 | (display-choices str) 34 | (displayln "") ;; terminating blank line 35 | (flush-output) 36 | (loop))) 37 | (exit 0)) 38 | 39 | (define find-module-path-completions 40 | (safe-dynamic-require 'drracket/find-module-path-completions 41 | 'find-module-path-completions 42 | (λ () (λ (_dir) (λ (_str) null))))) 43 | 44 | (define (init dir) 45 | (define get (find-module-path-completions dir)) 46 | (λ (str) 47 | (for ([x (in-list (get str))]) 48 | (displayln (path->string (cadr x)))))) 49 | -------------------------------------------------------------------------------- /racket/gui.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | ;; Note that racket/gui/dynamic is in `base` package --- requiring it 7 | ;; does NOT create a dependency on the `gui-lib` package. 8 | (require racket/gui/dynamic 9 | racket/port 10 | racket/system) 11 | 12 | (provide txt/gui 13 | make-initial-repl-namespace) 14 | 15 | ;; Attempt to load racket/gui/base eagerly, instantiating it in our 16 | ;; namespace and under our main custodian (as opposed to those used 17 | ;; for user programs). This is our strategy to avoid "racket/gui/base 18 | ;; cannot be instantiated more than once per process". 19 | ;; 20 | ;; The only scenarios where racket/gui/base won't be loaded eagerly 21 | ;; here: 22 | ;; 23 | ;; - It's not available: we're on a minimal Racket installation 24 | ;; where gui-lib is not installed. 25 | ;; 26 | ;; - It can't initialize: e.g. gui-lib is installed but errors with 27 | ;; 'Gtk initialization failed for display ":0"', because we're on a 28 | ;; headless system and our racket process wasn't run using xvfb-run. 29 | ;; Because this leaves gui-lib in a "semi-initialized" state where 30 | ;; `gui-available?` returns true but things don't actually work, we 31 | ;; really want to avoid this, so we check by using another racket 32 | ;; process. 33 | (when (parameterize ([current-error-port (open-output-nowhere)]) 34 | (system* (find-executable-path (find-system-path 'exec-file)) 35 | "-e" "(require racket/gui/base)")) 36 | (with-handlers ([exn:fail? void]) 37 | (dynamic-require 'racket/gui/base #f))) 38 | 39 | ;; #301: On Windows, show then hide an initial frame. 40 | (when (and (gui-available?) 41 | (eq? (system-type) 'windows)) 42 | (define make-object (dynamic-require 'racket/class 'make-object)) 43 | (define frame% (dynamic-require 'racket/gui/base 'frame%)) 44 | (define f (make-object frame% "Emacs Racket Mode initialization" #f 100 100)) 45 | (define dynamic-send (dynamic-require 'racket/class 'dynamic-send)) 46 | (dynamic-send f 'show #t) 47 | (dynamic-send f 'show #f)) 48 | 49 | (define-namespace-anchor anchor) 50 | (define our-ns (namespace-anchor->empty-namespace anchor)) 51 | (define (make-initial-repl-namespace) 52 | (define new-ns (make-base-namespace)) 53 | 54 | ;; If we loaded racket/gui/base above, then it is important for REPL 55 | ;; namespaces initially to have racket/gui/base _attached_, 56 | ;; regardless of whether a given user program `require`s it; a user 57 | ;; could `require` it at a REPL prompt. See also issue #555. 58 | (when (gui-available?) 59 | (namespace-attach-module our-ns 'racket/gui/base new-ns)) 60 | 61 | ;; Avoid potential problem (IIUC because Racket structs are 62 | ;; generative) with file/convertible by attaching the same instance 63 | ;; to user namespaces. 64 | ;; 65 | ;; Always do this. Things like pict-lib work without gui-lib, and we 66 | ;; can still do our feature where we "print images in the REPL". To 67 | ;; see how we do this using file/convertible, see print.rkt and 68 | ;; image.rkt. 69 | (namespace-attach-module our-ns 'file/convertible new-ns) 70 | 71 | ;; Likewise for number-markup struct used in elisp.rkt to accomodate 72 | ;; htdp/bsl; issue #732. 73 | (with-handlers ([exn:fail? void]) 74 | (namespace-attach-module our-ns 'simple-tree-text-markup/data new-ns)) 75 | 76 | new-ns) 77 | 78 | ;; Like mz/mr from racket/sandbox. 79 | (define-syntax txt/gui 80 | (syntax-rules () 81 | [(_ txtval guisym) 82 | (if (gui-available?) 83 | (dynamic-require 'racket/gui/base 'guisym) 84 | txtval)])) 85 | -------------------------------------------------------------------------------- /racket/hash-lang-bridge.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2020-2023 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/async-channel 7 | racket/class 8 | racket/match 9 | racket/runtime-path 10 | "elisp.rkt" 11 | "lang-info.rkt" 12 | "util.rkt") 13 | 14 | (provide hash-lang 15 | hash-lang-notify-channel) 16 | 17 | ;; Bridge for Emacs front end to use hash-lang% 18 | ;; 19 | ;; - Reference hash-lang% objects by a serializable ID supplied by the 20 | ;; front end. 21 | ;; 22 | ;; - Adjust Emacs 1-based positions to/from hash-lang% 0-based. 23 | ;; 24 | ;; - Handle notifications about changed languages and tokens, by 25 | ;; putting values to an async channel that is handled in 26 | ;; command-server.rkt, and then and up in Emacs, similar to 27 | ;; notifications used for logging and debugging. 28 | 29 | (define-runtime-path hash-lang.rkt "hash-lang.rkt") 30 | 31 | (define hash-lang-class-or-error-message 32 | (with-handlers ([exn:fail? exn-message]) 33 | (dynamic-require hash-lang.rkt 'hash-lang%))) 34 | 35 | (define our-hash-lang% 36 | (when (class? hash-lang-class-or-error-message) 37 | (class hash-lang-class-or-error-message 38 | (super-new) 39 | (init-field id) 40 | (define/override (on-changed-lang-info _gen li) 41 | (async-channel-put 42 | hash-lang-notify-channel 43 | (list 44 | 'hash-lang id 45 | 'lang 46 | 'module-language (lang-info-module-language li) 47 | 'racket-grouping (lang-info-grouping-position-is-racket? li) 48 | 'range-indenter (and (lang-info-range-indenter li) #t) 49 | 'submit-predicate (and (lang-info-submit-predicate li) #t) 50 | ;; String-ize paren-matches and quotes-matches data to avoid 51 | ;; discrepancies with Emacs Lisp allowed symbols and char 52 | ;; reader syntax. 53 | 'paren-matches (for/list ([o/c (in-list (lang-info-paren-matches li))]) 54 | (match-define (list o c) o/c) 55 | (cons (symbol->string o) (symbol->string c))) 56 | 'quote-matches (for/list ([c (in-list (lang-info-quote-matches li))]) 57 | (make-string 1 c)) 58 | 'comment-delimiters (lang-info-comment-delimiters li)))) 59 | (define/override (on-changed-tokens gen beg end) 60 | (when (< beg end) 61 | (async-channel-put hash-lang-notify-channel 62 | (list 'hash-lang id 63 | 'update 64 | gen (add1 beg) (add1 end)))))))) 65 | 66 | (define (hash-lang . args) 67 | (cond 68 | [(class? hash-lang-class-or-error-message) (apply hash-lang* args)] 69 | [(eq? 'create (car args)) #f] 70 | [else (error 'hash-lang hash-lang-class-or-error-message)])) 71 | 72 | (define (hash-lang* . args) 73 | (match args 74 | [`(create ,id ,ols ,str) (create id ols str)] 75 | [`(delete ,id) (delete id)] 76 | [`(update ,id ,gen ,pos ,old-len ,str) (update id gen pos old-len str)] 77 | [`(indent-amount ,id ,gen ,pos) (indent-amount id gen pos)] 78 | [`(indent-region-amounts ,id ,gen ,from ,upto) (indent-region-amounts id gen from upto)] 79 | [`(classify ,id ,gen ,pos) (classify id gen pos)] 80 | [`(grouping ,id ,gen ,pos ,dir ,limit ,count) (grouping id gen pos dir limit count)] 81 | [`(get-tokens ,id ,gen ,from ,upto) (get-tokens id gen from upto)] 82 | [`(submit-predicate ,id ,str ,eos?) (submit-predicate id str eos?)])) 83 | 84 | (define hash-lang-notify-channel (make-async-channel)) 85 | 86 | (define ht (make-hash)) ;id => hash-lang% 87 | (define (get-object id) 88 | (hash-ref ht id 89 | (λ () (error 'hash-lang-bridge 90 | "No hash-lang exists with ID ~v" id)))) 91 | 92 | (define (create id ols str) ;any/c (or/c #f string?) string? -> void 93 | (define obj (new our-hash-lang% 94 | [id id] 95 | [other-lang-source (and ols (not (null? ols)) ols)])) 96 | (hash-set! ht id obj) 97 | (send obj update! 1 0 0 str) 98 | id) 99 | 100 | (define (delete id) 101 | (hash-remove! ht id)) 102 | 103 | (define (update id gen pos old-len str) 104 | (send (get-object id) update! gen (sub1 pos) old-len str)) 105 | 106 | (define (indent-amount id gen pos) 107 | (with-time/log "hash-lang indent-amount" 108 | (send (get-object id) indent-line-amount gen (sub1 pos)))) 109 | 110 | (define (indent-region-amounts id gen from upto) 111 | (with-time/log "hash-lang indent-region-amounts" 112 | (match (send (get-object id) indent-range-amounts gen (sub1 from) (sub1 upto)) 113 | [#f 'false] ;avoid Elisp nil/`() punning problem 114 | [v v]))) 115 | 116 | (define (classify id gen pos) 117 | (match-define (list beg end attribs) (send (get-object id) classify gen (sub1 pos))) 118 | (list (add1 beg) (add1 end) (attribs->types attribs))) 119 | 120 | (define (grouping id gen pos dir limit count) 121 | (match (send (get-object id) grouping gen (sub1 pos) dir limit count) 122 | [(? number? n) (add1 n)] 123 | [v v])) 124 | 125 | (define (get-tokens id gen from upto) 126 | (for/list ([tok (in-list (send (get-object id) get-tokens gen (sub1 from) (sub1 upto)))]) 127 | (match-define (list (app add1 beg) (app add1 end) (app attribs->types types)) tok) 128 | (list beg end types))) 129 | 130 | (define (attribs->types attribs) 131 | (match attribs 132 | [(? symbol? s) (list s)] 133 | [(? hash? ht) (cons (or (hash-ref ht 'semantic-type-guess #f) 134 | (hash-ref ht 'type 'unknown)) 135 | (if (hash-ref ht 'comment? #f) 136 | '(sexp-comment-body) 137 | null))])) 138 | 139 | (define (submit-predicate id str -eos?) 140 | (define in (open-input-string str)) 141 | (define eos (as-racket-bool -eos?)) 142 | (send (get-object id) submit-predicate in eos)) 143 | 144 | (module+ example-0 145 | (define id 0) 146 | (define str "#lang racket\n42 (print \"hello\") @print{Hello} 'foo #:bar") 147 | (hash-lang 'create id str) 148 | (hash-lang 'update id 2 14 2 "9999") 149 | (hash-lang 'classify id 2 14) 150 | (hash-lang 'update id 3 14 4 "") 151 | (hash-lang 'classify id 3 14) 152 | (hash-lang 'classify id 3 15) 153 | (hash-lang 'grouping id 3 15 'forward 0 1)) 154 | 155 | (module+ example-1 156 | (define id 0) 157 | (define str "#lang at-exp racket\n42 (print \"hello\") @print{Hello (there)} 'foo #:bar") 158 | (hash-lang 'create id str) 159 | (hash-lang 'classify id 1 (sub1 (string-length str)))) 160 | 161 | (module+ example-1.5 162 | (define id 0) 163 | (define str "#lang scribble/manual\n(print \"hello\")\n@print[#:kw 12]{Hello (there) #:not-a-keyword}\n") 164 | (hash-lang 'create id str)) 165 | 166 | (module+ example-2 167 | (define id 0) 168 | (define str "#lang scribble/text\nHello @(print \"hello\") @print{Hello (there)} #:not-a-keyword") 169 | (hash-lang 'create id str) 170 | (hash-lang 'classify id (sub1 (string-length str)))) 171 | 172 | (module+ example-3 173 | (define id 0) 174 | (define str "#lang racket\n(λ () #t)") 175 | (hash-lang 'create id str) 176 | (hash-lang 'classify id 1 14) 177 | (hash-lang 'classify id 1 (sub1 (string-length str)))) 178 | 179 | (module+ example-4 180 | (define id 0) 181 | (define str "#lang racket\n#rx\"1234\"\n#(1 2 3)\n#'(1 2 3)") 182 | (hash-lang 'create id str)) 183 | 184 | (module+ example-5 185 | (define id 0) 186 | (define str "#lang racket\n123\n(print 123)\n") 187 | ;; 1234567890123 4567 890123456789 0 188 | ;; 1 2 3 189 | (hash-lang 'create id str) 190 | (indent-amount id 1 18) 191 | (update id 2 28 0 "\n") 192 | (indent-amount id 2 29)) 193 | -------------------------------------------------------------------------------- /racket/identifier.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/contract 7 | racket/format 8 | racket/match 9 | "syntax.rkt") 10 | 11 | (provide how/c 12 | ->identifier 13 | ->identifier-resolved-binding-info) 14 | 15 | ;;; Creating identifiers from symbols or strings 16 | 17 | ;; A simplifying helper for commands that want to work both ways, and 18 | ;; accept a first "how" or "context" argument that is either 19 | ;; 'namespace or a path-string. 20 | (define how/c (or/c 'namespace path-string?)) 21 | 22 | (define/contract (->identifier how v k) 23 | (-> how/c (or/c symbol? string?) (-> syntax? any) any) 24 | (match how 25 | ['namespace (->identifier/namespace v k)] 26 | [(? (and string? path-string?) p) (->identifier/expansion p v k)])) 27 | 28 | (define/contract (->identifier/namespace v k) 29 | (-> (or/c symbol? string?) (-> identifier? any/c) any/c) 30 | (define sym->id namespace-symbol->identifier) 31 | (k (cond [(string? v) (sym->id (string->symbol v))] 32 | [(symbol? v) (sym->id v)]))) 33 | 34 | ;; We use path-str to get expanded module syntax from the cache via 35 | ;; path->existing-expanded-syntax, and use the 'module-body-context 36 | ;; syntax property -- starting in Racket 6.5 -- which can be used as 37 | ;; lexical context to make an identifier. This lets identifier-binding 38 | ;; work for identifiers as if they were in that body's lexical context 39 | ;; -- including imported identifiers that aren't actually used as 40 | ;; bindings in the module body. 41 | (define/contract (->identifier/expansion path-str v k) 42 | (-> path-string? 43 | (or/c symbol? string?) 44 | (-> identifier? any/c) 45 | any/c) 46 | (path->existing-expanded-syntax 47 | path-str 48 | (λ (stx) 49 | (define (sym->id v) 50 | (expanded-module+symbol->identifier path-str stx v)) 51 | (k (cond [(string? v) (sym->id (string->symbol v))] 52 | [(symbol? v) (sym->id v)]))))) 53 | 54 | (define/contract (expanded-module+symbol->identifier path-str exp-mod-stx sym) 55 | (-> path-string? syntax? symbol? identifier?) 56 | ;; For imported bindings, this creates syntax where 57 | ;; identifier-binding will report a module-path-index that can be 58 | ;; resolved to a path that exists. Great! 59 | ;; 60 | ;; For module bindings, identifier-binding will say that the binding 61 | ;; exists. Good! But. Until a module declaration is evaluated, the 62 | ;; module has no name. As a result, the module-path-index is 63 | ;; reported as #. That would 64 | ;; resolve to -- wrong. 65 | ;; 66 | ;; Work-around: Let's record the path in the identifier's 67 | ;; syntax-source. Doing so won't change what identifier-binding 68 | ;; reports, but it means mpi->path can handle such a module path 69 | ;; index by instead using the path from syntax-source. 70 | (datum->syntax (syntax-property exp-mod-stx 'module-body-context) 71 | sym 72 | (list (string->path path-str) #f #f #f #f))) 73 | 74 | 75 | ;;; Massaging values returned by identifier-binding 76 | 77 | ;; A composition that does the right thing, including when making an 78 | ;; identifier that is a module binding. 79 | (define (->identifier-resolved-binding-info how v k) 80 | (->identifier how v 81 | (λ (id) 82 | (k (resolve-identifier-binding-info 83 | id 84 | (identifier-binding id)))))) 85 | 86 | ;; Given an identifier and the result from identifier-binding, returns 87 | ;; a subset of the information, where the module path indexes are 88 | ;; resolved to actual paths, and where the 'lexical value is treated 89 | ;; as #f. 90 | (define/contract (resolve-identifier-binding-info id binding-info) 91 | (-> identifier? 92 | (or/c 'lexical 93 | #f 94 | (list/c module-path-index? 95 | symbol? 96 | module-path-index? 97 | symbol? 98 | exact-nonnegative-integer? 99 | (or/c exact-integer? #f) 100 | (or/c exact-integer? #f)) 101 | (list/c symbol?)) 102 | (or/c #f 103 | (listof (cons/c symbol? 104 | (or/c 'kernel 105 | (cons/c path-string? (listof symbol?))))))) 106 | (match binding-info 107 | [(list source-mpi source-id 108 | nominal-source-mpi nominal-source-id 109 | source-phase 110 | import-phase 111 | nominal-export-phase) 112 | (list (cons source-id (id+mpi->path id source-mpi)) 113 | (cons nominal-source-id (id+mpi->path id nominal-source-mpi)))] 114 | [_ #f])) 115 | 116 | (define/contract (id+mpi->path id mpi) 117 | (-> identifier? 118 | module-path-index? 119 | (or/c 'kernel 120 | (cons/c path-string? (listof symbol?)))) 121 | (cond [;; We could check below for the interned -- or not in older 122 | ;; Rackets -- symbol '|expanded module|. That seems smelly. 123 | ;; Instead if we're a "self" module, and if the identifier 124 | ;; has a location -- probably supplied above by our 125 | ;; expanded-module+symbol->identifier -- use that source. 126 | (and (self-module? mpi) 127 | (syntax-source id)) 128 | (list (syntax-source id))] 129 | [else 130 | (match (resolved-module-path-name 131 | (module-path-index-resolve mpi)) 132 | [(? hash-percent-symbol) 'kernel] 133 | [(? path-string? path) (list path)] 134 | [(? symbol? sym) 135 | (list (build-path (current-load-relative-directory) 136 | (~a sym ".rkt")))] 137 | [(list (? path-string? path) (? symbol? subs) ...) 138 | (list* path subs)] 139 | ;; I've seen this odd case occur only when running 140 | ;; test/find.rkt. The module path index is 141 | ;; #, and resolving that is (find-examples m) when 143 | ;; it should be '(# m). 144 | [(list (? symbol?) (? symbol? subs) ...) 145 | (list* (syntax-source id) subs)])])) 146 | 147 | (define (self-module? mpi) 148 | (define-values (a b) (module-path-index-split mpi)) 149 | (and (not a) (not b))) 150 | 151 | (define (hash-percent-symbol v) 152 | (and (symbol? v) 153 | (regexp-match? #px"^#%" (symbol->string v)))) 154 | 155 | (module+ test 156 | (require rackunit 157 | "syntax.rkt") 158 | ;; Check something that is in the namespace resulting from 159 | ;; module->namespace on, say, this source file. 160 | (parameterize ([current-namespace (module->namespace (syntax-source #'here))]) 161 | (check-not-false (->identifier-resolved-binding-info 'namespace 'match values)) 162 | (check-not-false (->identifier-resolved-binding-info 'namespace "match" values))) 163 | 164 | ;; Check something that is not in the current namespace, but is an 165 | ;; identifier in the lexical context of an expanded module form -- 166 | ;; including imported identifiers -- from the expanded syntax 167 | ;; cache. 168 | (define top (case (system-type) [(windows) "C:\\"] [(unix macosx) "/"])) 169 | (define path-str (path->string (build-path top "path" "to" "foobar.rkt"))) 170 | (define code-str (~a '(module foobar racket/base 171 | (require net/url racket/set) 172 | (let ([a-lexical-binding 42]) 173 | a-lexical-binding) 174 | (define a-module-binding 42) 175 | a-module-binding))) 176 | ;; Get the expanded syntax in our cache 177 | (string->expanded-syntax path-str code-str void) 178 | ;; Simple imported binding 179 | (check-not-false (->identifier-resolved-binding-info path-str 'set? values)) 180 | (check-not-false (->identifier-resolved-binding-info path-str "set?" values)) 181 | ;; Import where renaming/contracting is involved 182 | (check-not-false (->identifier-resolved-binding-info path-str 'get-pure-port values)) 183 | (check-not-false (->identifier-resolved-binding-info path-str "get-pure-port" values)) 184 | ;; Get a module binding 185 | (check-equal? (->identifier-resolved-binding-info path-str "a-module-binding" values) 186 | (let ([path (string->path path-str)]) 187 | `((a-module-binding ,path) 188 | (a-module-binding ,path)))) 189 | ;; Get a lexical binding: Should return false 190 | (check-false (->identifier-resolved-binding-info path-str "a-lexical-binding" values)) 191 | ;; Get something that's not a binding in at all: Should return false 192 | (check-false (->identifier-resolved-binding-info path-str "ASDFASDFDS" values)) 193 | ;; Get whatever in some file not in expanded syntax cache: Should return false 194 | (check-false (->identifier-resolved-binding-info "not/yet/expanded.rkt" "whatever" values))) 195 | -------------------------------------------------------------------------------- /racket/image.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | ;; Portions Copyright (C) 2012 Jose Antonio Ortega Ruiz. 7 | 8 | ;; Limit imports to those supplied by Minimal Racket! 9 | (require file/convertible 10 | racket/file 11 | racket/format 12 | racket/match) 13 | 14 | (provide set-use-svg?! 15 | convert-image) 16 | 17 | ;; Emacs front end tells us whether SVG is an image file type Emacs 18 | ;; can render. This comes via a command line flag when we start up. 19 | (define use-svg? #t) 20 | (define (set-use-svg?! v) (set! use-svg? v)) 21 | 22 | ;; For a given value, pretty-print-size-hook can be called multiple 23 | ;; times (!) followed once by pretty-print-print-hook. So because 24 | ;; convert-and-save does non-trivial work, we cache. 25 | (define ht (make-weak-hasheq)) ;weak because #624 26 | 27 | (define (convert-image v #:remove-from-cache? [remove? #f]) 28 | (and (convertible? v) 29 | (begin0 (hash-ref! ht v 30 | (λ () (raw-convert-image v))) 31 | (when remove? 32 | (hash-remove! ht v))))) 33 | 34 | (define (raw-convert-image v) 35 | ;; Rationale for the order here: 36 | ;; 37 | ;; - Try bounded before unbounded flavors. Because we want 38 | ;; accurate image width, if available, for pretty-printing. 39 | ;; 40 | ;; - Within each flavor: Try svg (if this Emacs can use it) 41 | ;; before png. Because space. 42 | (define fmts/exts (if use-svg? 43 | '((svg-bytes+bounds8 "svg") 44 | (png-bytes+bounds8 "png") 45 | (svg-bytes+bounds "svg") 46 | (png-bytes+bounds "png") 47 | (svg-bytes "svg") 48 | (png-bytes "png")) 49 | '((png-bytes+bounds8 "png") 50 | (png-bytes+bounds "png") 51 | (png-bytes "png")))) 52 | (for/or ([fmt/ext (in-list fmts/exts)]) 53 | (apply convert-and-save v fmt/ext))) 54 | 55 | (define (convert-and-save v fmt ext) 56 | (define (default-width _) 4096) 57 | (match (convert v fmt #f) 58 | [(or (list* (? bytes? bstr) width _) ;bytes+bounds 59 | (and (? bytes? bstr) (app default-width width))) ;bytes 60 | (define filename (make-temporary-file (~a "racket-image-~a." ext))) 61 | (with-output-to-file filename #:exists 'truncate (λ () (display bstr))) 62 | (cons (path->string filename) width)] 63 | [#f #f])) 64 | -------------------------------------------------------------------------------- /racket/instrument.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang at-exp racket/base 5 | 6 | (require (only-in errortrace/errortrace-key 7 | errortrace-key) 8 | (only-in errortrace/errortrace-lib 9 | error-context-display-depth) 10 | errortrace/stacktrace 11 | racket/match 12 | racket/set 13 | racket/unit) 14 | 15 | (provide make-instrumented-eval-handler 16 | error-context-display-depth 17 | get-error-trace 18 | instrumenting-enabled 19 | test-coverage-enabled 20 | clear-test-coverage-info! 21 | get-uncovered 22 | profiling-enabled 23 | clear-profile-info! 24 | get-profile) 25 | 26 | ;;; Core instrumenting 27 | 28 | (define instrumenting-enabled (make-parameter #f)) 29 | 30 | (define (make-instrumented-eval-handler [orig-eval (current-eval)]) 31 | ;; This is modeled after the one in DrRacket. 32 | (define (racket-mode-instrumented-eval-handler orig-exp) 33 | (cond 34 | [(or #;(not (instrumenting-enabled)) 35 | (compiled-expression? (if (syntax? orig-exp) 36 | (syntax-e orig-exp) 37 | orig-exp))) 38 | (orig-eval orig-exp)] 39 | [else 40 | (let loop ([exp (if (syntax? orig-exp) 41 | orig-exp 42 | (namespace-syntax-introduce 43 | (datum->syntax #f orig-exp)))]) 44 | (let ([top-e (expand-syntax-to-top-form exp)]) 45 | (syntax-case top-e (begin) 46 | [(begin expr ...) 47 | ;; Found a `begin', so expand/eval each contained 48 | ;; expression one at a time 49 | (let i-loop ([exprs (syntax->list #'(expr ...))] 50 | [last-one (list (void))]) 51 | (cond 52 | [(null? exprs) 53 | (apply values last-one)] 54 | [else 55 | (i-loop (cdr exprs) 56 | (call-with-values 57 | (λ () 58 | (call-with-continuation-prompt 59 | (λ () (loop (car exprs))) 60 | (default-continuation-prompt-tag) 61 | (λ args 62 | (apply 63 | abort-current-continuation 64 | (default-continuation-prompt-tag) 65 | args)))) 66 | list))]))] 67 | [_else 68 | ;; Not `begin', so proceed with normal expand and eval 69 | (orig-eval (errortrace-annotate top-e #f))])))])) 70 | racket-mode-instrumented-eval-handler) 71 | 72 | ;;; Better stack traces ("basic errortrace") 73 | 74 | (define (should-annotate? stx phase) ;stacktrace-filter^ 75 | (and (syntax-source stx) 76 | (syntax-property stx 'errortrace:annotate))) 77 | 78 | (define key-module-name 'errortrace/errortrace-key) ;^key-module-name 79 | 80 | (define (with-mark mark expr phase) ;^stracktrace-imports 81 | ;; This is modeled after the one in errortrace-lib. Specifically, 82 | ;; use `make-st-mark' for its capture of the original syntax to show 83 | ;; in the stack trace error message. 84 | (match (make-st-mark mark phase) 85 | [#f expr] 86 | [mark 87 | (with-syntax ([expr expr] 88 | [mark mark] 89 | [etk errortrace-key] 90 | [wcm (syntax-shift-phase-level #'with-continuation-mark phase)]) 91 | (syntax (wcm etk mark expr)))])) 92 | 93 | ;; Functional alternative to print-error-trace. 94 | (define (get-error-trace e) 95 | (for/list ([_ (error-context-display-depth)] 96 | [stx (in-list 97 | (map st-mark-source 98 | (continuation-mark-set->list (exn-continuation-marks e) 99 | errortrace-key)))] 100 | #:when stx) 101 | (cons (syntax->datum stx) 102 | (srcloc (syntax-source stx) 103 | (syntax-line stx) 104 | (syntax-column stx) 105 | (syntax-position stx) 106 | (syntax-span stx))))) 107 | 108 | ;;; Test coverage 109 | 110 | (define test-coverage-enabled (make-parameter #f)) ;stacktrace-imports^ 111 | 112 | (define test-coverage-info (make-hasheq)) ;(hash/c syntax? mpair?). 113 | ;; This approach taken from DrR. Presumably set-mcar! is faster than a 114 | ;; box, which in turn is faster than hash-set!. The cdr cell is 115 | ;; ignored. 116 | 117 | (define (clear-test-coverage-info!) 118 | (hash-clear! test-coverage-info)) 119 | 120 | (define (initialize-test-coverage-point expr) ;stacktrace-imports^ 121 | (hash-set! test-coverage-info expr (mcons #f #f))) 122 | 123 | (define (test-covered expr) ;stacktrace-imports^ 124 | (define v (hash-ref test-coverage-info expr #f)) 125 | (and v (with-syntax ([v v]) 126 | #'(#%plain-app set-mcar! v #t)))) 127 | 128 | (define (get-uncovered source) 129 | (for/set ([stx (in-list (get-uncovered-expressions source))]) 130 | (define beg (syntax-position stx)) 131 | (define end (+ beg (syntax-span stx))) 132 | (cons beg end))) 133 | 134 | ;; from sandbox-lib 135 | (define (get-uncovered-expressions source) 136 | (let* ([xs (hash-map test-coverage-info 137 | (lambda (k v) (cons k (mcar v))))] 138 | [xs (filter (lambda (x) (and (syntax-position (car x)) 139 | (equal? (syntax-source (car x)) source))) 140 | xs)] 141 | [xs (sort xs (lambda (x1 x2) 142 | (let ([p1 (syntax-position (car x1))] 143 | [p2 (syntax-position (car x2))]) 144 | (or (< p1 p2) ; earlier first 145 | (and (= p1 p2) 146 | (> (syntax-span (car x1)) ; wider first 147 | (syntax-span (car x2))))))))] 148 | [xs (reverse xs)]) 149 | (if (null? xs) 150 | xs 151 | (let loop ([xs (cdr xs)] [r (list (car xs))]) 152 | (if (null? xs) 153 | (map car (filter (lambda (x) (not (cdr x))) r)) 154 | (loop (cdr xs) 155 | (cond [(not (and (= (syntax-position (caar xs)) 156 | (syntax-position (caar r))) 157 | (= (syntax-span (caar xs)) 158 | (syntax-span (caar r))))) 159 | (cons (car xs) r)] 160 | [(cdar r) r] 161 | [else (cons (car xs) (cdr r))]))))))) 162 | 163 | ;;; Profiling 164 | 165 | (define profile-key (gensym)) ;stacktrace-imports^ 166 | 167 | (define profiling-enabled (make-parameter #f)) ;stacktrace-imports^ 168 | 169 | (define profile-info (make-hasheq)) ;(hash/c any/c prof?) 170 | 171 | (define (clear-profile-info!) 172 | (hash-clear! profile-info)) 173 | 174 | (struct prof 175 | (nest? ;guard nested calls 176 | num ;exact-nonnegative-integer? 177 | time ;exact-nonnegative-integer? 178 | name ;(or/c #f symbol?) 179 | expr) ;syntax? 180 | #:mutable 181 | #:transparent) 182 | 183 | (define (initialize-profile-point key name expr) ;stacktrace-imports^ 184 | (hash-set! profile-info 185 | key 186 | (prof #f 0 0 (and (syntax? name) (syntax-e name)) expr))) 187 | 188 | (define (register-profile-start key) ;stacktrace-imports^ 189 | (define p (hash-ref profile-info key)) 190 | (set-prof-num! p (add1 (prof-num p))) 191 | (cond [(prof-nest? p) #f] 192 | [else (set-prof-nest?! p #t) 193 | (current-process-milliseconds)])) 194 | 195 | (define (register-profile-done key start) ;stacktrace-imports^ 196 | (void 197 | (when start 198 | (define p (hash-ref profile-info key)) 199 | (set-prof-nest?! p #f) 200 | (set-prof-time! p (+ (- (current-process-milliseconds) start) 201 | (prof-time p)))))) 202 | 203 | (define (get-profile) 204 | (for/list ([x (in-list (hash-values profile-info))]) 205 | (match-define (prof _nest? count msec name stx) x) 206 | (define src (syntax-source stx)) 207 | (define beg (syntax-position stx)) 208 | (define end (and beg (+ beg (syntax-span stx)))) 209 | (list count 210 | msec 211 | (and name (symbol->string name)) 212 | (and src (path? src) (path->string src)) 213 | beg 214 | end))) 215 | 216 | 217 | ;;; Finally, invoke the unit 218 | 219 | (define-values/invoke-unit/infer stacktrace/filter/errortrace-annotate@) 220 | -------------------------------------------------------------------------------- /racket/interaction.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang at-exp racket/base 5 | 6 | (require racket/format 7 | racket/gui/dynamic 8 | racket/match 9 | racket/set 10 | "safe-dynamic-require.rkt" 11 | "gui.rkt" 12 | "repl-output.rkt" 13 | "repl-session.rkt" 14 | "stack-checkpoint.rkt") 15 | 16 | (provide get-interaction) 17 | 18 | ;; This input port holds the unread remainder of the most-recent 19 | ;; submission string from the current-submissions channel. Although 20 | ;; commonly each submission is one read-able value, like "1\n", it 21 | ;; might contain more than one read-able value, e.g. if the user 22 | ;; submits "1 2 3\n". We want to read all. Furthermore, we don't want 23 | ;; to display unnecessary prompts for the subsequent ones. 24 | (define current-submission-input-port (make-parameter (open-input-string ""))) 25 | 26 | (define (get-interaction prompt) 27 | (maybe-warn-for-session) 28 | (define (get) 29 | (with-handlers ([exn:fail:read? 30 | (λ (exn) 31 | ;; Discard remainder after this read error. 32 | (current-submission-input-port (open-input-string "")) 33 | (raise exn))]) 34 | (current-get-interaction-input-port (λ () (current-submission-input-port))) 35 | (with-stack-checkpoint 36 | ((current-read-interaction) 'racket-mode-repl (current-submission-input-port))))) 37 | (define v (get)) 38 | (cond 39 | [(eof-object? v) 40 | (repl-output-prompt (string-append prompt ">")) 41 | (match-define (cons expr echo?) (get-submission)) 42 | (when echo? 43 | (repl-output-message (string-append expr " => "))) 44 | (current-submission-input-port (open-input-string expr)) 45 | (port-count-lines! (current-submission-input-port)) 46 | (get)] 47 | [else v])) 48 | 49 | (define current-get-interaction-evt 50 | (safe-dynamic-require 'racket/base 'current-get-interaction-evt)) 51 | 52 | ;; Get value from current-submissions channel in the best manner 53 | ;; available given the version of Racket. Avoids hard dependency on 54 | ;; Racket 8.4+. 55 | (define (get-submission) 56 | (cond 57 | [current-get-interaction-evt 58 | (let loop () 59 | (sync 60 | (handle-evt ((current-get-interaction-evt)) ;allow GUI yield 61 | (λ (thk) 62 | (thk) 63 | (loop))) 64 | (current-submissions)))] 65 | [else 66 | ((txt/gui sync yield) (current-submissions))])) 67 | 68 | ;; Note: We try to eagerly load racket/gui/base in gui.rkt. See 69 | ;; comments there, explaining why. 70 | ;; 71 | ;; As a result, gui-available? here merely means that a user program 72 | ;; _could_ use it (e.g. gui-lib is installed and running on a 73 | ;; non-headless system where Gtk can initialize). 74 | ;; 75 | ;; As a result, a user on a GUI-capable Racket install will see the 76 | ;; warning at the start of _every_ REPL session -- not just when first 77 | ;; running a GUI program (which would be more desirable, but I don't 78 | ;; immediately see how to do that). 79 | (define warned-sessions (mutable-set)) 80 | (define (maybe-warn-for-session) 81 | (unless current-get-interaction-evt 82 | (when (gui-available?) 83 | (unless (set-member? warned-sessions (current-session-id)) 84 | (set-add! warned-sessions (current-session-id)) 85 | (repl-output-message 86 | @~a{Warning: GUI programs might not work correctly because 87 | your version of Racket lacks `current-get-interaction-evt`, 88 | which was added in Racket 8.4.}))))) 89 | -------------------------------------------------------------------------------- /racket/keywords.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang typed/racket/no-check 5 | 6 | ;; Generate lists for Racket keywords, builtins, and types. 7 | ;; 8 | ;; The question of what is a "keyword" and a "builtin" is not so 9 | ;; simple in Racket: 10 | ;; 11 | ;; 1. The distinction between the two is squishy, and from one point 12 | ;; of view Racket has 1400+ "primitives" (!). 13 | ;; 14 | ;; 2. As for "builtins", there are many, many "batteries included" 15 | ;; libraries in the main distribution. Where to draw the line? 16 | ;; 17 | ;; 3. More fundamentally, Racket is a language for making languages. 18 | ;; Ultimately the only way to be 100% correct is to do something 19 | ;; "live" with namespace-mapped-symbols. But I don't see that as 20 | ;; performant for Emacs font-lock. 21 | ;; 22 | ;; Here I'm saying that: 23 | ;; 24 | ;; (a) "keywords" are syntax (only) from racket/base 25 | ;; 26 | ;; (b) "builtins" are everything else provided by #lang racket and 27 | ;; #lang typed/racket (except the capitalized Types from typed/racket 28 | ;; go into their own list). Plus for modern macros, racket/syntax and 29 | ;; a few items from syntax/parse (but not its syntax classes, because 30 | ;; `id` and `str` are too "generic" and too likely to be user program 31 | ;; identifiers). 32 | ;; 33 | ;; Is that somewhat arbitrary? Hell yes. It's my least-worst, 34 | ;; practical idea for now. Also, IMHO it's an improvement over getting 35 | ;; pull requests to add people's favorites, a few at a time. At least 36 | ;; this way is consistent, and can be regenerated programatically as 37 | ;; Racket evolves. 38 | 39 | (define (symbol<=? a b) 40 | (string<=? (symbol->string a) (symbol->string b))) 41 | 42 | (define (exports mod #:only-stx? [only-stx? #f]) 43 | (define (ids phases) 44 | (for*/list ([phase phases] 45 | [item (cdr phase)]) 46 | (car item))) 47 | (define-values (vars stxs) (module->exports mod)) 48 | (sort (remove-duplicates (append (ids stxs) 49 | (if only-stx? '() (ids vars))) 50 | eq?) 51 | symbol<=?)) 52 | 53 | (define (subtract xs ys) 54 | (for*/list ([x xs] #:when (not (memq x ys))) x)) 55 | 56 | (define base-stx (exports 'racket/base #:only-stx? #t)) 57 | 58 | (define rkt (append (exports 'racket) 59 | (exports 'racket/syntax) 60 | '(syntax-parse syntax-parser define-simple-macro))) 61 | (define rkt+ (subtract rkt base-stx)) 62 | 63 | (define tr (exports 'typed/racket)) 64 | (define tr+ (subtract tr rkt)) ;This includes Types, too 65 | 66 | (define Types (for/list ([x tr+] 67 | #:when (char-upper-case? (string-ref (symbol->string x) 0))) 68 | x)) 69 | 70 | ;;; The final lists 71 | 72 | (define keywords base-stx) 73 | 74 | (define builtins 75 | (sort (subtract (remove-duplicates (append rkt+ 76 | (subtract tr+ Types)) 77 | eq?) 78 | base-stx) 79 | symbol<=?)) 80 | 81 | ;; So many builtins, Emacs gives "regexp too long" error, so split into two: 82 | (define-values (builtins1 builtins2) 83 | (let ([mid (/ (length builtins) 2)]) 84 | (for/fold ([xs '()] 85 | [ys '()]) 86 | ([x builtins] 87 | [i (in-naturals)]) 88 | (cond [(< i mid) (values (cons x xs) ys)] 89 | [else (values xs (cons x ys))])))) 90 | 91 | (define types Types) 92 | 93 | ;;; Print 94 | 95 | (define (prn xs) 96 | (pretty-print (map symbol->string (sort xs symbol<=?)))) 97 | 98 | ;; Enter each submodule to print a quoted list of symbols, then copy 99 | ;; and paste each list into racket-keywords-and-builtins.el. 100 | (module+ types (prn types)) 101 | (module+ keywords (prn keywords)) 102 | (module+ builtins1 (prn builtins1)) 103 | (module+ builtins2 (prn builtins2)) 104 | -------------------------------------------------------------------------------- /racket/lang-info.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2020-2023 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (provide (struct-out lang-info) 7 | lang-info-grouping-position-is-racket?) 8 | 9 | ;; This is its own file really just so that hash-lang.bridge.rkt can 10 | ;; require it normally and not need to do more dynamic-requires. 11 | 12 | (struct lang-info 13 | (module-language 14 | lexer 15 | paren-matches 16 | quote-matches 17 | grouping-position 18 | line-indenter 19 | range-indenter 20 | submit-predicate 21 | comment-delimiters) 22 | #:transparent #:authentic) 23 | 24 | (define racket-grouping-position 25 | (with-handlers ([exn:fail? (λ _ #f)]) 26 | (dynamic-require 'syntax-color/racket-navigation 'racket-grouping-position))) 27 | 28 | (define (lang-info-grouping-position-is-racket? li) 29 | (equal? (lang-info-grouping-position li) racket-grouping-position)) 30 | 31 | -------------------------------------------------------------------------------- /racket/lib-pkg.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2024 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/match 7 | racket/set 8 | (only-in syntax/modresolve 9 | resolve-module-path) 10 | setup/dirs 11 | setup/getinfo 12 | pkg/lib 13 | "define-fallbacks.rkt") 14 | 15 | (define-fallbacks setup/dirs 16 | [(get-base-documentation-packages) '("racket-doc")] 17 | [(get-distribution-documentation-packages) '("main-distribution") ]) 18 | 19 | (provide lib-pkg-sort) 20 | 21 | ;; This code for classifying packages as "base" or "main-dist" is 22 | ;; borrowed from racket-index/scribblings/main/private/pkg.rkt 23 | (define base-pkgs #f) 24 | (define main-dist-pkgs #f) 25 | (define pkg-cache-for-pkg-directory (make-hash)) 26 | 27 | (define (get-base-pkgs) 28 | (unless base-pkgs 29 | (set! base-pkgs (find-pkgs (get-base-documentation-packages)))) 30 | base-pkgs) 31 | 32 | (define (get-main-dist-pkgs) 33 | (unless main-dist-pkgs 34 | (set! main-dist-pkgs (find-pkgs (get-distribution-documentation-packages) 35 | #:exclude (list->set (get-base-pkgs))))) 36 | main-dist-pkgs) 37 | 38 | (define (find-pkgs root-pkg-names #:exclude [excludes (set)]) 39 | (define result '()) 40 | (define seen (set-copy excludes)) 41 | (for ([root-pkg-name (in-list root-pkg-names)]) 42 | (match (pkg-directory 43 | root-pkg-name 44 | #:cache pkg-cache-for-pkg-directory) 45 | [#f '()] 46 | [_ 47 | (let loop ([pkg root-pkg-name]) 48 | (unless (set-member? seen pkg) 49 | (set-add! seen pkg) 50 | (match (pkg-directory pkg #:cache pkg-cache-for-pkg-directory) 51 | [#f 52 | ;; these are platform dependent packages (like racket-win32-i386-3) 53 | ;; they have no deps, and if they are platform dependent, 54 | ;; they are not that useful (for documentation search) anyway 55 | (set! result (cons pkg result))] 56 | [dir 57 | (set! result (cons pkg result)) 58 | (define get-info (get-info/full dir)) 59 | (define direct-deps 60 | (for/list ([dep (extract-pkg-dependencies get-info #:build-deps? #f)]) 61 | (match dep 62 | [(? string?) dep] 63 | [(cons dep _) dep]))) 64 | ;; we need to recur. For example, 2dtabular is in 2d-lib, 65 | ;; which is not a direct dep of main-distribution 66 | (for ([dep direct-deps]) 67 | (loop dep))])))])) 68 | result) 69 | 70 | ;; However we can't follow the example of web search, which builds its 71 | ;; index at doc build time. The package info known at doc build time 72 | ;; doesn't make it into the xref index. 73 | ;; 74 | ;; So instead: When a doc index item has an "exported from lib", we 75 | ;; use resolve-module-path and path->pkg. However this is moderately 76 | ;; expensive, and should be done lazily (definitely not eagerly for 77 | ;; all 32K+ xref-index items) and cached. 78 | 79 | (define pkg-cache-for-path->pkg (make-hash)) 80 | (define ns (make-base-namespace)) 81 | (define (pkg-name mp) 82 | (match (parameterize ([current-namespace ns]) 83 | (resolve-module-path mp)) 84 | [(or (? path? p) 85 | (list* 'submod (? path? p))) 86 | (path->pkg p 87 | #:cache pkg-cache-for-path->pkg)] 88 | [_ #f])) 89 | 90 | (define cache (make-hash)) 91 | (define (lib-pkg-sort maybe-mod-path) 92 | (hash-ref! 93 | cache 94 | maybe-mod-path 95 | (λ () 96 | (with-handlers ([exn:fail? (λ _ 9)]) 97 | (define p (pkg-name maybe-mod-path)) 98 | (cond [(not p) 0] 99 | [(member p (get-base-pkgs)) 1] 100 | [(member p (get-main-dist-pkgs)) 2] 101 | [else 3]))))) 102 | -------------------------------------------------------------------------------- /racket/logger.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022, 2025 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang at-exp racket/base 5 | 6 | (require racket/match 7 | racket/format) 8 | 9 | (provide (rename-out [command-channel logger-command-channel] 10 | [notify-channel logger-notify-channel])) 11 | 12 | ;; "On start-up, Racket creates an initial logger that is used to 13 | ;; record events from the core run-time system. For example, an 'debug 14 | ;; event is reported for each garbage collection (see Garbage 15 | ;; Collection)." Use that; don't create new one. See issue #325. 16 | (define global-logger (current-logger)) 17 | 18 | (define command-channel (make-channel)) 19 | (define notify-channel (make-channel)) 20 | 21 | ;; Go ahead and start our log receiver thread early so we can see our 22 | ;; own racket-mode topic's 'debug level ouput in the front end. 23 | ;; 24 | ;; On the other hand (see #631) set all other topics to the 'fatal 25 | ;; level (least noisy). This avoids sending excessive logger 26 | ;; notifications to the front end, until/unless it gives us the user's 27 | ;; logger configuration, with whatever verbosity they desire. 28 | (define (racket-mode-log-receiver-thread) 29 | (let wait ([receiver (make-receiver '((racket-mode . debug) 30 | (* . fatal)))]) 31 | (sync 32 | (handle-evt command-channel 33 | (λ (v) 34 | (wait (make-receiver v)))) 35 | (handle-evt receiver 36 | (match-lambda 37 | [(vector level message _v topic) 38 | (channel-put notify-channel 39 | `(logger 40 | ,(cons level 41 | (topic+message topic message)))) 42 | (wait receiver)]))))) 43 | (void (thread racket-mode-log-receiver-thread)) 44 | 45 | (define (topic+message topic message) 46 | (match message 47 | [(pregexp (format "^~a: (.*)$" (regexp-quote (~a topic))) 48 | (list _ message)) 49 | (list topic 50 | message)] 51 | [message-without-topic 52 | (list (or topic '*) 53 | message-without-topic)])) 54 | 55 | (module+ test 56 | (require rackunit) 57 | (check-equal? (topic+message 'topic "message") 58 | (list 'topic "message")) 59 | (check-equal? (topic+message 'topic "topic: message") 60 | (list 'topic "message")) 61 | (check-equal? (topic+message #f "message") 62 | (list '* "message"))) 63 | 64 | (define (make-receiver alist) 65 | (apply make-log-receiver (list* global-logger 66 | (alist->spec alist)))) 67 | 68 | ;; Convert from ([logger . level] ...) alist to the format used by 69 | ;; make-log-receiver: (level logger ... ... default-level). In the 70 | ;; alist, treat the logger '* as the default level. 71 | (define (alist->spec xs) ;(Listof (Pairof Symbol Symbol)) -> (Listof Symbol) 72 | (for/fold ([spec '()]) 73 | ([x (in-list xs)]) 74 | (append spec 75 | (match x 76 | [(cons '* level) (list level)] 77 | [(cons logger level) (list level logger)])))) 78 | -------------------------------------------------------------------------------- /racket/main.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2025 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later. 3 | 4 | #lang racket/base 5 | 6 | ;; This module acts as a "shim" or "launcher" for command-server.rkt. 7 | ;; 8 | ;; We dynamic-require command-server.rkt within an exn handler for 9 | ;; missing modules, to provide a better error UX when people are using 10 | ;; Minimal Racket; see issue #744. Any such error is written to stdout 11 | ;; as a "notification" for the Emacs front end, which can display it 12 | ;; in a dedicated buffer. Not only is this better than error text 13 | ;; flashing by in the echo bar and hiding in the *Messages* buffer, 14 | ;; our dedicated can supply a browse-url button to our docs section 15 | ;; about Minimal Racket. 16 | ;; 17 | ;; Note that the exn handler is active only during the dynamic extent 18 | ;; of the dynamic-require to extract the command-server-loop function. 19 | ;; Subsequently we call that function without any such handler in 20 | ;; effect. 21 | ;; 22 | ;; Use the same notification mechanism for other back end startup 23 | ;; failures, such as when they need a newer version of Racket. 24 | 25 | ;; Limit imports to those supplied by Minimal Racket! 26 | (require racket/match 27 | (only-in racket/port open-output-nowhere) 28 | racket/runtime-path 29 | (only-in racket/string string-trim) 30 | (only-in racket/system system/exit-code) 31 | version/utils 32 | (only-in "image.rkt" set-use-svg?!)) 33 | 34 | ;; Write a "notification" for the Emacs front end and exit. 35 | (define (notify/exit kind data) 36 | (writeln `(startup-error ,kind ,data)) 37 | (flush-output) 38 | (exit 13)) 39 | 40 | (define (assert-racket-version minimum-version) 41 | (define actual-version (version)) 42 | (unless (version<=? minimum-version actual-version) 43 | (notify/exit 44 | 'other 45 | (format "Racket Mode needs Racket ~a or newer but ~a is ~a." 46 | minimum-version 47 | (find-executable-path (find-system-path 'exec-file)) 48 | actual-version)) 49 | (flush-output) 50 | (exit 14))) 51 | 52 | (define (macos-sequoia-or-newer?) 53 | (and (eq? 'macosx (system-type 'os)) 54 | ;; Note: This is conservative; will return false if `sw_vers` 55 | ;; can't be found or doesn't produce a valid version string. 56 | (let ([out (open-output-string)]) 57 | (parameterize ([current-output-port out]) 58 | (and (zero? (system/exit-code "sw_vers -productVersion")) 59 | (let ([ver (string-trim (get-output-string out))]) 60 | (and (valid-version? ver) 61 | (version<=? "15.0" ver)))))))) 62 | 63 | (module+ main 64 | (assert-racket-version (if (macos-sequoia-or-newer?) 65 | "8.14.0.4" ;issue #722 66 | "7.8")) ;general requirement 67 | 68 | ;; Command-line flags (from Emacs front end invoking us) 69 | (match (current-command-line-arguments) 70 | [(vector "--use-svg" ) (set-use-svg?! #t)] 71 | [(vector "--do-not-use-svg") (set-use-svg?! #f)] 72 | [v 73 | (notify/exit 74 | 'other 75 | (format "Bad command-line arguments:\n~s\n" v))]) 76 | 77 | (define-runtime-path command-server.rkt "command-server.rkt") 78 | (define command-server-loop 79 | (with-handlers ([exn:fail:syntax:missing-module? 80 | (λ (e) 81 | (notify/exit 82 | 'missing-module 83 | (format "~a" (exn:fail:syntax:missing-module-path e))))]) 84 | (dynamic-require command-server.rkt 'command-server-loop))) 85 | 86 | ;; Save original current-{input output}-port to give to 87 | ;; command-server-loop for command I/O ... 88 | (let ([stdin (current-input-port)] 89 | [stdout (current-output-port)]) 90 | ;; ... and set no-ops so rando print can't bork the command I/O. 91 | (parameterize ([current-input-port (open-input-bytes #"")] 92 | [current-output-port (open-output-nowhere)]) 93 | (command-server-loop stdin stdout)))) 94 | -------------------------------------------------------------------------------- /racket/online-check-syntax.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/logging 7 | racket/match 8 | racket/set 9 | syntax/parse/define 10 | "util.rkt") 11 | 12 | (provide current-online-check-syntax 13 | with-online-check-syntax) 14 | 15 | ;;; online-check-syntax logger monitor 16 | 17 | ;; There exists a protocol for macros to communicate tooltips to 18 | ;; DrRacket via a log-message to the logger 'online-check-syntax. This 19 | ;; might seem strange, but one motivation for this protocol is that 20 | ;; e.g. a type-checker might learn things during expansion that it 21 | ;; would like to show the user -- even if expansion fails. 22 | 23 | (define current-online-check-syntax (make-parameter (mutable-set))) 24 | 25 | (define-simple-macro (with-online-check-syntax source:expr e:expr ...+) 26 | (call-with-online-check-syntax source (λ () e ...))) 27 | 28 | (define (call-with-online-check-syntax source proc) 29 | (current-online-check-syntax (mutable-set)) ;reset 30 | (with-intercepted-logging (make-interceptor source) proc 31 | 'info 'online-check-syntax)) 32 | 33 | (define ((make-interceptor src) event) 34 | (match-define (vector _level _message stxs _topic) event) 35 | (for ([stx (in-list stxs)]) 36 | (let walk ([v (syntax-property stx 'mouse-over-tooltips)]) 37 | (match v 38 | ;; "The value of the 'mouse-over-tooltips property is 39 | ;; expected to be to be a tree of cons pairs (in any 40 | ;; configuration)..." 41 | [(cons v more) 42 | (walk v) 43 | (walk more)] 44 | ;; "...whose leaves are either ignored or are vectors of the 45 | ;; shape:" 46 | [(vector (? syntax? stx) 47 | (? exact-positive-integer? beg) 48 | (? exact-positive-integer? end) 49 | (or (? string? string-or-thunk) 50 | (? procedure? string-or-thunk))) 51 | (when (equal? src (syntax-source stx)) 52 | ;; Force now; the resulting string will likely use less 53 | ;; memory than a thunk closure. 54 | (define (force v) (if (procedure? v) (v) v)) 55 | (define str (force string-or-thunk)) 56 | (set-add! (current-online-check-syntax) 57 | (list beg end str)))] 58 | ;; Expected; quietly ignore 59 | [(or (list) #f) (void)] 60 | ;; Unexpected; log warning and ignore 61 | [v (log-racket-mode-warning "unknown online-check-syntax ~v" v) 62 | (void)])))) 63 | -------------------------------------------------------------------------------- /racket/print.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/match 7 | racket/pretty 8 | "image.rkt" 9 | (only-in "repl-output.rkt" 10 | print-images-as-specials?)) 11 | 12 | (provide make-pretty-global-port-print-handler) 13 | 14 | (define (make-pretty-global-port-print-handler columns pixels/char) 15 | (define (racket-mode-pretty-global-port-print-handler v out [depth 0]) 16 | (unless (void? v) 17 | (if (print-images-as-specials?) 18 | (parameterize ([print-syntax-width +inf.0] 19 | [pretty-print-columns columns] 20 | [pretty-print-size-hook (size-hook pixels/char)] 21 | [pretty-print-print-hook print-hook]) 22 | (pretty-print v out depth #:newline? #f)) 23 | (pretty-print v out depth #:newline? #f)))) 24 | racket-mode-pretty-global-port-print-handler) 25 | 26 | ;; Return char width of convertible image. 27 | (define ((size-hook pixels/char) value _display? _port) 28 | (match (convert-image value) ;caches 29 | [(cons _path-name pixel-width) 30 | (inexact->exact 31 | (ceiling 32 | (/ pixel-width pixels/char)))] 33 | [#f #f])) 34 | 35 | ;; Note: "The print-hook procedure is applied to a value for printing 36 | ;; when the sizing hook (see pretty-print-size-hook) returns an 37 | ;; integer size for the value." i.e. But not called otherwise. 38 | (define (print-hook value _display? port) 39 | (match (convert-image value #:remove-from-cache? #t) 40 | [(cons path-name _pixel-width) 41 | (write-special (cons 'image path-name) port)])) 42 | -------------------------------------------------------------------------------- /racket/repl-session.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang at-exp racket/base 5 | 6 | (require racket/format 7 | racket/match 8 | "util.rkt") 9 | 10 | (provide call-with-session-context 11 | current-session-id 12 | current-repl-msg-chan 13 | current-submissions 14 | current-session-maybe-mod 15 | current-repl-output-manager 16 | (struct-out session) 17 | get-session 18 | set-session! 19 | remove-session!) 20 | 21 | ;;; REPL session "housekeeping" 22 | 23 | ;; Each REPL session has an entry in this hash-table. 24 | (define sessions (make-hasheq)) ;number? => session? 25 | 26 | (struct session 27 | (thread ;thread? the repl manager thread 28 | repl-out-mgr ;thread? the repl output manager thread 29 | repl-msg-chan ;channel? 30 | submissions ;channel? 31 | maybe-mod ;(or/c #f module-path?) 32 | namespace) 33 | #:transparent) 34 | 35 | (define (get-session sid) 36 | (hash-ref sessions sid #f)) 37 | 38 | (define (set-session! sid maybe-mod) 39 | (hash-set! sessions sid (session (current-thread) 40 | (current-repl-output-manager) 41 | (current-repl-msg-chan) 42 | (current-submissions) 43 | maybe-mod 44 | (current-namespace))) 45 | (log-racket-mode-debug @~a{(set-session! @~s[sid] @~s[maybe-mod]) => sessions: @~s[sessions]})) 46 | 47 | (define (remove-session! sid) 48 | (hash-remove! sessions sid) 49 | (log-racket-mode-debug @~a{(remove-session! @~v[sid]) => sessions: @~v[sessions]})) 50 | 51 | (define current-session-id (make-parameter #f)) 52 | (define current-repl-msg-chan (make-parameter #f)) 53 | (define current-submissions (make-parameter #f)) 54 | (define current-session-maybe-mod (make-parameter #f)) 55 | (define current-repl-output-manager (make-parameter #f)) 56 | 57 | ;; A way to parameterize e.g. commands that need to work with a 58 | ;; specific REPL session. Called from e.g. a command-server thread. 59 | (define (call-with-session-context sid proc . args) 60 | (match (get-session sid) 61 | [(? session? s) 62 | (log-racket-mode-debug @~a{@~v[@car[args]]: using session ID @~v[sid]}) 63 | (parameterize ([current-session-id sid] 64 | [current-repl-output-manager (session-repl-out-mgr s)] 65 | [current-repl-msg-chan (session-repl-msg-chan s)] 66 | [current-submissions (session-submissions s)] 67 | [current-session-maybe-mod (session-maybe-mod s)] 68 | [current-namespace (session-namespace s)]) 69 | (apply proc args))] 70 | [_ 71 | (unless (equal? sid '()) 72 | (log-racket-mode-warning @~a{@~v[@car[args]]: session ID @~v[sid] not found})) 73 | (apply proc args)])) 74 | -------------------------------------------------------------------------------- /racket/safe-dynamic-require.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2024 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (provide safe-dynamic-require 7 | module-installed? 8 | rhombus-installed?) 9 | 10 | ;; Although dynamic-require calls `fail-thunk` when `id` does not 11 | ;; exist in `mod`, it raises exn:fail if `mod` doesn't exist. 12 | ;; 13 | ;; This wrapper calls fail-thunk consistently. 14 | (define (safe-dynamic-require mod id [fail-thunk (λ () #f)]) 15 | (with-handlers ([exn:fail? (λ _ (fail-thunk))]) 16 | (dynamic-require mod id fail-thunk))) 17 | 18 | ;; Some predicates useful for e.g. tests that may run against various 19 | ;; versions of Racket. 20 | 21 | (define (module-installed? mod) 22 | (and (safe-dynamic-require mod #f) 23 | #t)) 24 | 25 | (define (rhombus-installed?) 26 | (module-installed? 'rhombus)) 27 | -------------------------------------------------------------------------------- /racket/stack-checkpoint.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2022 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require racket/list 7 | racket/match 8 | syntax/parse/define) 9 | 10 | (provide with-stack-checkpoint 11 | continuation-mark-set->trimmed-context) 12 | 13 | ;;; Inspired by drracket/private/stack-checkpoint.rkt. 14 | 15 | ;; Run a thunk, and if an exception is raised, make it possible to 16 | ;; trim the stack so that the surrounding context is hidden 17 | (define checkpoints (make-weak-hasheq)) 18 | (define (call-with-stack-checkpoint thunk) 19 | (define checkpoint #f) 20 | (call-with-exception-handler 21 | (λ (exn) 22 | (when checkpoint ; just in case there's an exception before it's set 23 | (define key (if (exn? exn) (exn-continuation-marks exn) exn)) 24 | (unless (hash-has-key? checkpoints key) 25 | (hash-set! checkpoints key checkpoint))) 26 | exn) 27 | (λ () 28 | (set! checkpoint (current-continuation-marks)) 29 | (thunk)))) 30 | 31 | (define-simple-macro (with-stack-checkpoint e:expr ...+) 32 | (call-with-stack-checkpoint (λ () e ...))) 33 | 34 | ;; Like continuation-mark-set->context, but trims any tail registered 35 | ;; as a checkpoint, as well as removing items lacking srcloc. 36 | (define (continuation-mark-set->trimmed-context cms) 37 | (define stack (continuation-mark-set->context cms)) 38 | (filter 39 | cdr ;only non-#f srcloc 40 | (match (hash-ref checkpoints cms #f) 41 | [(? continuation-mark-set? v) 42 | (define checkpoint (continuation-mark-set->context v)) 43 | ;; To drop the common tail, reverse both and use drop-common-prefix. 44 | (define-values (trimmed _) (drop-common-prefix (reverse stack) 45 | (reverse checkpoint))) 46 | (match trimmed 47 | ;; The mark for call-with-stack-checkpoint is the head; ignore 48 | ;; it. Reverse the remainder back to stack order. 49 | [(cons _ xs) (reverse xs)] 50 | ;; Can happen with Racket < 7.0 and debugger REPL. 51 | [_ '()])] 52 | [#f stack]))) 53 | -------------------------------------------------------------------------------- /racket/util.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require (for-syntax racket/base) 7 | syntax/parse/define 8 | racket/format 9 | "define-fallbacks.rkt" 10 | "safe-dynamic-require.rkt") 11 | 12 | (provide string->namespace-syntax 13 | syntax-or-sexpr->syntax 14 | syntax-or-sexpr->sexpr 15 | nat/c 16 | pos/c 17 | memq? 18 | log-racket-mode-debug 19 | log-racket-mode-info 20 | log-racket-mode-warning 21 | log-racket-mode-error 22 | log-racket-mode-fatal 23 | time-apply/log 24 | with-time/log 25 | with-memory-use/log 26 | (all-from-out "define-fallbacks.rkt") 27 | (all-from-out "safe-dynamic-require.rkt")) 28 | 29 | (define (string->namespace-syntax str) 30 | (namespace-syntax-introduce 31 | (read-syntax #f (open-input-string str)))) 32 | 33 | (define (syntax-or-sexpr->syntax v) 34 | (if (syntax? v) 35 | v 36 | (namespace-syntax-introduce (datum->syntax #f v)))) 37 | 38 | (define (syntax-or-sexpr->sexpr v) 39 | (if (syntax? v) 40 | (syntax-e v) 41 | v)) 42 | 43 | (define nat/c exact-nonnegative-integer?) 44 | (define pos/c exact-positive-integer?) 45 | 46 | (define (memq? x xs) 47 | (and (memq x xs) #t)) 48 | 49 | ;;; logger / timing 50 | 51 | (define-logger racket-mode) 52 | 53 | (define (time-apply/log what proc args) 54 | (define-values (vs cpu real gc) (time-apply proc args)) 55 | (define (fmt n) (~s #:align 'right #:min-width 4 n)) 56 | (log-racket-mode-debug "~a cpu | ~a real | ~a gc :: ~a" 57 | (fmt cpu) (fmt real) (fmt gc) what) 58 | (apply values vs)) 59 | 60 | (define-simple-macro (with-time/log what e ...+) 61 | (time-apply/log what (λ () e ...) '())) 62 | 63 | (define (memory-use/log what thunk) 64 | (define before (current-memory-use)) 65 | (begin0 (thunk) 66 | (let ([after (current-memory-use)]) 67 | (define (mb n) 68 | (~a (~r #:min-width 4 69 | #:precision 0 70 | (/ n 1024.0 1024.0)) 71 | " MB")) 72 | (log-racket-mode-debug "~a [~a => ~a] :: ~a" 73 | (mb (- after before)) 74 | (mb before) 75 | (mb after) 76 | what)))) 77 | 78 | (define-simple-macro (with-memory-use/log what e ...+) 79 | (memory-use/log what (λ () e ...))) 80 | -------------------------------------------------------------------------------- /racket/xref.rkt: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2013-2024 by Greg Hendershott. 2 | ;; SPDX-License-Identifier: GPL-3.0-or-later 3 | 4 | #lang racket/base 5 | 6 | (require setup/xref) 7 | 8 | (provide get-xref) 9 | 10 | ;; A single xref instance for all our modules to share. 11 | ;; 12 | ;; Will block safely until ready, if used from e.g. delay/thread or 13 | ;; delay/idle (which, although we're not doing now, we've done before, 14 | ;; and might do again someday). 15 | (define sema (make-semaphore 1)) 16 | (define xref (call-with-semaphore sema load-collections-xref)) 17 | (define (get-xref) (call-with-semaphore sema (λ () xref))) 18 | -------------------------------------------------------------------------------- /test/example/.gitattributes: -------------------------------------------------------------------------------- 1 | # Exclude from GitHub language stats all test example files: 2 | * linguist-vendored 3 | -------------------------------------------------------------------------------- /test/example/indent.rkt: -------------------------------------------------------------------------------- 1 | ;; -*- racket-indent-sequence-depth: 100; racket-indent-curly-as-sequence: t; faceup-properties: (face syntax-table); -*- 2 | 3 | ;;; NOTE: After changing this file you will need to M-x faceup-write-file 4 | ;;; to regenerate the .faceup test comparison file. 5 | ;;; 6 | ;;; NOTE: You may need to disable certain features temporarily while 7 | ;;; doing M-x faceup-write-file. See CONTRIBUTING.md for examples. 8 | 9 | ;;; Quoted list 10 | 11 | '(a b 12 | (a b 13 | c)) 14 | 15 | '((1) 2 3 16 | (3) 17 | 4 5) 18 | 19 | ;;; Quasiquoted list (align with head) and unquote or unquote-splicing 20 | ;;; (use normal indent rules for the form). 21 | 22 | `(Part () 23 | (PartNumber () 24 | ,part) 25 | (ETag () 26 | ,etag)) 27 | 28 | `((,(x) 29 | ,y)) 30 | 31 | `(Delete 32 | ,@(for/list ([p (in-list paths)]) 33 | `(Object () 34 | (Key () ,p)))) 35 | 36 | ;;; Syntax 37 | 38 | #'(for/list ([x xs]) 39 | x) 40 | 41 | #`(for/list ([x xs]) 42 | x) 43 | 44 | #'(#%app (#%app hasheq (quote a) (quote 42)) 45 | (quote a)) 46 | 47 | (#%app (#%app hasheq (quote a) (quote 42)) 48 | (quote a)) 49 | 50 | #'(foo (#%app hasheq (quote a) (quote 42)) 51 | (quote a)) 52 | 53 | ;;; Rackjure style dictionary (when racket-indent-curly-as-sequence is t). 54 | 55 | {a b 56 | c d} 57 | 58 | {a b 59 | c d 60 | b '(a x 61 | s (x y 62 | x v))} 63 | 64 | ;;; Vector 65 | 66 | #(a b 67 | c d) 68 | 69 | ;;; List with a keyword as first member (e.g. in many contracts) 70 | 71 | (#:x y 72 | #:y x) 73 | 74 | ;;; Normal function application. 75 | 76 | (foobar x 77 | y 78 | z) 79 | 80 | (foobar 81 | x 82 | y 83 | z) 84 | 85 | (dict-set a 86 | b 87 | c) 88 | 89 | (dict-set 90 | a 91 | b 92 | c) 93 | 94 | (call-with-values (lambda () (values 1 2)) 95 | +) 96 | 97 | (call-with-values 98 | (lambda () (values 1 2)) 99 | +) 100 | 101 | ;;; Forms with special indentation 102 | 103 | (let ([x 0]) 104 | x) 105 | 106 | (let/cc cc 107 | cc) 108 | 109 | (let/cc cc : Any 110 | cc) 111 | 112 | ;; indent 2 113 | 114 | (syntax-case stx () 115 | [(_ x) #'#f] 116 | [(_ x y) #'#t]) 117 | 118 | ;; indent 3 119 | 120 | (syntax-case* stx () x 121 | [(_ x) #'#f] 122 | [(_ x y) #'#t]) 123 | 124 | (syntax-case* 125 | stx 126 | (#%module-begin 127 | module 128 | define-values 129 | define-syntaxes 130 | define 131 | define/contract 132 | define-syntax 133 | struct 134 | define-struct) 135 | x 136 | [(_ x) #'#f] 137 | [(_ x y) #'#t]) 138 | 139 | ;; begin and cond have 0 style 140 | (begin 141 | 0 142 | 0) 143 | 144 | (begin 0 145 | 0) 146 | 147 | (cond [1 2] 148 | [3 4]) 149 | 150 | (cond 151 | [1 2] 152 | [3 4]) 153 | 154 | (if a 155 | x 156 | x) 157 | 158 | ;; begin* 159 | 160 | (begin-for-foo 0 161 | 0) 162 | 163 | (begin-for-foo 164 | 0 165 | 0) 166 | 167 | (with-handlers ([x y]) 168 | a b c) 169 | 170 | ;; def, with-, call-with- and other 'defun style 171 | 172 | (define (x) x x 173 | x) 174 | 175 | (struct x x 176 | ()) 177 | 178 | (match-define (list x y) 179 | (list 1 2)) 180 | 181 | (with-output-to-file path #:mode 'text #:exists 'replace 182 | (λ () (display "Hello, world."))) 183 | 184 | (call-with-output-file path #:mode 'text #:exists 'replace 185 | (λ (out) (display "Hello, world." out))) 186 | 187 | 188 | ;;; Special forms: When the first non-distinguished form is on the 189 | ;;; same line as distinguished forms, disregard it for indent. 190 | 191 | ;; module has indent 2 192 | 193 | (module 1 194 | 2 195 | 3 196 | 4 197 | 5) 198 | 199 | ;; Normal case 200 | (module 1 2 201 | 3 202 | 4 203 | 5) 204 | 205 | ;; Weird case -- but this is how scheme-mode indents it. 206 | (module 1 2 3 207 | 4 208 | 5) 209 | 210 | ;; Weird case -- but this is how scheme-mode indents it. 211 | (module 1 2 3 4 212 | 5) 213 | 214 | ;;; for/fold 215 | 216 | (for/fold ([a 0] 217 | [b 0]) 218 | ([x 0] 219 | [y 0]) 220 | #t) 221 | 222 | (for/fold 223 | ([a 0] 224 | [b 0]) 225 | ([x 0] 226 | [y 0]) 227 | #t) 228 | 229 | (for/fold : T 230 | ([a 0] 231 | [b 0]) 232 | ([x 0] 233 | [y 0]) 234 | #t) 235 | 236 | (for/fold 237 | : T 238 | ([a 0] 239 | [b 0]) 240 | ([x 0] 241 | [y 0]) 242 | #t) 243 | 244 | ;;; for/hasheq 245 | 246 | (for/hasheq ([i (in-range 1 10)]) 247 | (values i i)) 248 | 249 | (for/hasheq 250 | ([i (in-range 1 10)]) 251 | (values i i)) 252 | 253 | (for/hasheq : (Immutable-HashTable Number Number) 254 | ([i (in-range 1 10)]) 255 | (values i i)) 256 | 257 | (for/hasheq 258 | : (Immutable-HashTable Number Number) 259 | ([i (in-range 1 10)]) 260 | (values i i)) 261 | 262 | ;;; Bug #50 263 | 264 | '((x 265 | y) A 266 | z 267 | (x 268 | y) A 269 | z) 270 | 271 | (match args 272 | [(list x) (x 273 | y)] ... 274 | [(list x) (x y)] ... 275 | [(list x) (x y)] ...) 276 | 277 | (define-syntax (fstruct stx) 278 | (syntax-parse stx 279 | [(_ id:id (field:id ...)) 280 | (with-syntax ([(accessor ...) 281 | (for/list ([fld (in-list (syntax->list #'(field ...)))]) 282 | (format-id stx "~a-~a" (syntax->datum #'id) fld))]) 283 | #'(serializable-struct 284 | id (field ...) #:transparent 285 | #:property prop:procedure 286 | (lambda (self . args) 287 | (match args 288 | [(list 'field) (accessor self)] ... 289 | [(list (list 'field)) (accessor self)] ... 290 | [(list (list-rest 'field fields)) ((accessor self) fields)] ... 291 | [(list-rest 'field f args) 292 | (struct-copy id self 293 | [field (apply f (accessor self) args)])] ... 294 | [(list-rest (list 'field) f args) ;<-- THIS SEXPR IS INDENTED TOO FAR 295 | (struct-copy id self 296 | [field (apply f (accessor self) args)])] ... 297 | [(list-rest (list-rest 'field fields) args) 298 | (struct-copy id self 299 | [field (apply (accessor self) fields args)])] ...))))])) 300 | 301 | ;; Bug #123 302 | 303 | #hash([a . (#hash() 304 | 0)] 305 | [b . (#hasheq() 306 | 0)] 307 | [c . (#fx(0 1 2) 308 | 0)] 309 | [d . (#fx3(0 1 2) 310 | 0)] 311 | [e . (#fl(0.0 1.0 2.0) 312 | 0)] 313 | [f . (#fl3(0.0 1.0 2.0) 314 | 0)] 315 | [g . (#s(foo x) 316 | 0)] 317 | [h . (#3(0 1 2) 318 | 0)]) 319 | 320 | ;; Bug #136 321 | 322 | #;(list 1 323 | #;2 324 | 3) 325 | 326 | (list 1 327 | #;(list 1 328 | (let ([x 2] 329 | #;[y 3]) 330 | x) 331 | 3) 332 | 2 333 | 3) 334 | 335 | ;; Bug #243 336 | (cond [x y 337 | z] 338 | [(= a x) y 339 | z]) 340 | 341 | ;; Bug #262 342 | (define-metafunction λL 343 | ∪ : (x ...) ... -> (x ...) 344 | [(∪ any_ls ...) 345 | ,(apply append (term (any_ls ...)))]) 346 | 347 | ;; Issue #516 348 | (lambda (f [a : Number] 349 | [b : Number]) : Number 350 | 10) 351 | 352 | (lambda (f [a : Number] 353 | [b : Number]) 354 | : Number 355 | 10) 356 | 357 | ;; Issue #521 358 | (define-judgment-form L 359 | #:mode (⇓ I I O O) 360 | #:contract (⇓ Γ e Δ v) 361 | 362 | [----------- Value 363 | (⇓ Γ v Γ v)] 364 | 365 | 366 | [(⇓ Γ e Δ (λ (y) e_*)) 367 | (⇓ Δ (subst e_* y x) Θ v) 368 | ------------------------- Application 369 | (⇓ Γ (e x) Θ v)]) 370 | 371 | ;; Issue #558 372 | (module+ test 373 | (+ 374 | 1 375 | #< any/c any)])) 13 | (define (contracted2 x) x) 14 | (provide/contract [contracted2 (-> any/c any)]) 15 | 16 | (define (c/r x) x) 17 | (provide (contract-out [rename c/r contracted/renamed (-> any/c any)])) 18 | 19 | (define-syntax-rule (plain-definer name) 20 | (begin 21 | (define (name x) x) 22 | (provide name))) 23 | (plain-definer plain-by-macro) 24 | 25 | (define-syntax-rule (contracted-definer name) 26 | (begin 27 | (define (name x) x) 28 | (provide (contract-out [name (-> any/c any)])))) 29 | (contracted-definer contracted-by-macro) 30 | 31 | ;; This is here to try to trip naive matching, by having a definition 32 | ;; of `sub` that is not actually provided, unlike the one in the `sub` 33 | ;; module just below. 34 | (module red-herring racket/base 35 | (define (sub) #f)) 36 | 37 | (module sub racket/base 38 | (define (sub x) x) 39 | (provide sub 40 | (rename-out [sub sub/renamed]))) 41 | (require 'sub) 42 | (provide sub sub/renamed) 43 | 44 | ;; Likewise, another case of naive matching: 45 | (module red-herring-2 racket/base 46 | (define (foo) #f)) 47 | 48 | (define (foo x) x) 49 | (provide foo) 50 | 51 | ;; Issue 317 52 | (define a-number 42) 53 | (provide a-number) 54 | (define a-parameter (make-parameter #f)) 55 | (provide a-parameter) 56 | 57 | (module m racket/base 58 | (define from-m #f) 59 | (provide from-m)) 60 | (require 'm) 61 | (provide (contract-out [from-m any/c])) 62 | -------------------------------------------------------------------------------- /test/racket/find.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require racket/format 4 | racket/list 5 | racket/match 6 | racket/runtime-path 7 | rackunit 8 | syntax/modread 9 | "../../racket/find.rkt" 10 | "../../racket/syntax.rkt" 11 | "find-examples.rkt") 12 | 13 | (define ((path-ends-in? . xs) ps) 14 | (list-prefix? (reverse (map string->path xs)) 15 | (reverse (explode-path ps)))) 16 | (define (not-0 v) (not (= 0 v))) 17 | (define (not-1 v) (not (= 1 v))) 18 | 19 | (define-runtime-path parent-dir "../../racket/") 20 | 21 | (define (test how) 22 | (check-equal? (find-definition how "display") 23 | 'kernel) 24 | (check-equal? (find-signature how "display") 25 | '("defined in #%kernel, signature unavailable")) 26 | 27 | (check-match (find-definition how "displayln") 28 | (list (? (path-ends-in? "racket" "private" "misc.rkt")) 29 | (? not-1) 30 | (? not-0))) 31 | (check-equal? (find-signature how "displayln") 32 | '((displayln v) (displayln v p))) ;case-lambda defn 33 | 34 | ;; Test a definer macro that (as of Racket 6.7) does not properly 35 | ;; set srcloc: Can we at least return a specfic location for its 36 | ;; parent syntax (as opposed to line 1 column 0)? 37 | (check-match (find-definition how "in-hash") 38 | (list (? (path-ends-in? "racket" "private" "for.rkt")) 39 | (? not-1) 40 | (? not-0))) 41 | 42 | ;; Tests for specific locations in find-examples.rkt 43 | 44 | (check-match (find-definition how "plain") 45 | (list (pregexp "find-examples.rkt$") 7 9)) 46 | (check-equal? (find-signature how "plain") 47 | '(plain x)) 48 | 49 | (check-match (find-definition how "renamed") 50 | (list (pregexp "find-examples.rkt$") 7 9)) 51 | (check-equal? (find-signature how "renamed") 52 | '(plain x)) 53 | 54 | (check-match (find-definition how "contracted1") 55 | (list (pregexp "find-examples.rkt$") 11 9)) 56 | (check-equal? (find-signature how "contracted1") 57 | '(contracted1 x)) 58 | 59 | (check-match (find-definition how "contracted2") 60 | (list (pregexp "find-examples.rkt$") 13 9)) 61 | (check-equal? (find-signature how "contracted2") 62 | '(contracted2 x)) 63 | 64 | (check-match (find-definition how "contracted/renamed") 65 | (list (pregexp "find-examples.rkt$") 16 9)) 66 | (check-equal? (find-signature how "contracted/renamed") 67 | '(c/r x)) 68 | 69 | (check-match (find-definition how "plain-by-macro") 70 | (list (pregexp "find-examples.rkt$") 23 15)) 71 | (check-false (find-signature how "plain-by-macro")) 72 | 73 | (check-match (find-definition how "contracted-by-macro") 74 | (list (pregexp "find-examples.rkt$") 29 20)) 75 | (check-false (find-signature how "contracted-by-macro")) 76 | 77 | (check-match (find-definition how "sub") 78 | (list (pregexp "find-examples.rkt$") 38 11)) 79 | (check-equal? (find-signature how "sub") 80 | '(sub x)) 81 | 82 | (check-match (find-definition how "sub/renamed") 83 | (list (pregexp "find-examples.rkt$") 38 11)) 84 | (check-equal? (find-signature how "sub/renamed") 85 | '(sub x)) 86 | 87 | (check-match (find-definition how "foo") 88 | (list (pregexp "find-examples.rkt$") 48 9)) 89 | (check-equal? (find-signature how "foo") 90 | '(foo x)) 91 | 92 | (check-match (find-definition how "a-number") 93 | (list (pregexp "find-examples.rkt$") 52 8)) 94 | 95 | (check-match (find-definition how "a-parameter") 96 | (list (pregexp "find-examples.rkt$") 54 8)) 97 | 98 | (check-match (find-definition how "from-m") 99 | (list (pregexp "find-examples.rkt$") 58 10)) 100 | 101 | ;; This is (roughly) a test of opening a Racket source file and 102 | ;; doing M-. on every non-list sexpr: Call find-definition on each 103 | ;; sexpr. Not-found (#f) is fine. But fail test for (list _ 1 0) -- 104 | ;; i.e. the source file was found, but not the location within. 105 | (define (check-non-bof-location file) 106 | (define ht (make-hash)) 107 | (define (find k) ;memoized find-definition how 108 | (hash-ref ht k 109 | (λ () 110 | (define v (find-definition how (format "~a" k))) 111 | (hash-set! ht k v) 112 | v))) 113 | (define (walk v) 114 | (if (list? v) 115 | (for-each walk v) 116 | (match (find v) 117 | [(list where 1 0) 118 | (fail @~a{can't find definition of `@|v|` in @where})] 119 | [_ (void)]))) 120 | (walk 121 | (with-module-reading-parameterization 122 | ;; Why read not read-syntax? Because we only care about the 123 | ;; sexprs as text: `find-definition` takes a string, because 124 | ;; `racket-visit-definition` takes text from an Emacs buffer. 125 | (λ () (with-input-from-file file read))))) 126 | (for ([file '(("commands" "requires.rkt") 127 | ("repl.rkt"))]) 128 | (check-non-bof-location (apply build-path parent-dir file)))) 129 | 130 | 131 | ;; Exercise "how" = 'namespace 132 | (define-namespace-anchor nsa) 133 | (parameterize ([current-namespace (namespace-anchor->namespace nsa)]) 134 | (test 'namespace)) 135 | 136 | ;; Exercise "how" = a specific file 137 | (define this-file (path->string (syntax-source #'here))) 138 | (file->expanded-syntax this-file 139 | (λ (_stx) 140 | (test this-file))) 141 | --------------------------------------------------------------------------------