├── .gitattributes ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── checkers.ms ├── checkers.ss ├── config-params.ss ├── config.ss ├── configuration.md ├── copy-dlls ├── cursor.ss ├── doc.ss ├── flycheck.ss ├── indent.ms ├── indent.ss ├── indentation.md ├── json.ss ├── keywords.ss ├── lsp-swish.el ├── lsp.ms ├── lsp.ss ├── main.ss ├── os-process.ss ├── progress.ms ├── progress.ss ├── read.ms ├── read.ss ├── software-info.ss ├── testing ├── common.ss ├── pipe.ss └── rpc.ss ├── tower-client.ss ├── tower.ss └── trace.ss /.gitattributes: -------------------------------------------------------------------------------- 1 | *.ms linguist-language=Scheme 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.mo 2 | *.so 3 | *.sop 4 | *.ss.html 5 | *.wpo 6 | *~ 7 | coverage.html 8 | git.revision 9 | git.tag 10 | mat-actual/ 11 | mat-expected/ 12 | mat-report.html 13 | profile.data 14 | static-keywords 15 | swish-lint 16 | swish-lint.boot 17 | swish-lint.exe 18 | swish.info 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 Beckman Coulter, Inc. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean coverage install lint test 2 | 3 | SRC := $(shell git ls-files '*.ss') 4 | INSTALLROOT := ~/.emacs.d/swish-lint 5 | 6 | ifeq (Windows_NT,${OS}) 7 | EXESUFFIX:= .exe 8 | SCHEME_LIBPATH:=$(shell cygpath -w "$$(dirname "$$(type -p scheme)")") 9 | else 10 | EXESUFFIX:= 11 | SCHEME_LIBPATH:= 12 | endif 13 | 14 | all: swish-lint${EXESUFFIX} 15 | 16 | swish-lint${EXESUFFIX}:: | prepare-source 17 | swish-lint${EXESUFFIX}:: git.revision ${SRC} 18 | @./copy-dlls -s "${SCHEME_LIBPATH}" 19 | swish-build -o $@ main.ss -b petite --rtlib swish --libs-visible 20 | 21 | test: all 22 | swish-test --progress test --report mat-report.html . 23 | 24 | coverage: all 25 | rm -f profile.data 26 | swish-test --progress test --report mat-report.html --save-profile profile.data --coverage coverage.html --exclude 'testing/**' . 27 | 28 | lint: swish-lint${EXESUFFIX} ${SRC} 29 | ./swish-lint${EXESUFFIX} ${SRC} 30 | 31 | # force evaluation, but use a different target from the output that 32 | # main.ss depends on so we don't rebuild needlessly 33 | .PHONY: prepare-source 34 | prepare-source: 35 | @git describe --always --exclude='*' --abbrev=40 --dirty > git.revision.tmp 36 | @if cmp --quiet git.revision git.revision.tmp; then \ 37 | rm git.revision.tmp; \ 38 | else \ 39 | mv git.revision.tmp git.revision; touch software-info.ss; echo "git.revision changed"; \ 40 | fi 41 | @git describe --tags --dirty | sed -E 's/^v//; s/-g[0-9a-f]+//' > git.tag.tmp 42 | @if cmp --quiet git.tag git.tag.tmp; then \ 43 | rm git.tag.tmp; \ 44 | else \ 45 | mv git.tag.tmp git.tag; touch software-info.ss; echo "git.tag changed"; \ 46 | fi 47 | @echo '(json:pretty (software-info))' | swish -q > swish.info.tmp 48 | @if cmp --quiet swish.info swish.info.tmp; then \ 49 | rm swish.info.tmp; \ 50 | else \ 51 | mv swish.info.tmp swish.info; touch software-info.ss; echo "swish.info changed"; \ 52 | fi 53 | 54 | install: all 55 | install -d ${INSTALLROOT} 56 | install swish-lint${EXESUFFIX} ${INSTALLROOT} 57 | install -m 644 swish-lint.boot ${INSTALLROOT} 58 | install -m 644 lsp-swish.el ${INSTALLROOT} 59 | ifeq (Windows_NT,${OS}) 60 | install csv*.dll uv.dll osi.dll sqlite3.dll ${INSTALLROOT} 61 | endif 62 | 63 | clean: 64 | rm -f git.revision git.tag swish.info 65 | rm -f swish-lint${EXESUFFIX} swish-lint.boot 66 | rm -f *.{so,mo,wpo,sop,ss.html} 67 | rm -f testing/*.{so,mo,wpo,sop,ss.html} 68 | rm -f profile.data coverage.html mat-report.html 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Swish-Lint 2 | 3 | Swish-Lint analyzes source code to flag stylistic errors, helps 4 | developers navigate code bases, and provides code completion. It 5 | provides feedback to improve code quality during development before 6 | reviews and inspections. Swish-Lint provides language features like 7 | auto completion, go to definition, and find all references to editors 8 | like Emacs and VSCode that support the [Language Server 9 | Protocol](https://microsoft.github.io/language-server-protocol/). 10 | 11 | Features include: 12 | 13 | - Code completion 14 | - Goto definition 15 | - Find references 16 | - [Indentation](indentation.md) 17 | 18 | ## Build Requirements 19 | 20 | - [Swish](https://github.com/becls/swish) 2.6 or later built using Chez Scheme 9.6.4 or later 21 | 22 | ## Build 23 | 24 | 1. `make` 25 | 26 | 2. `make install` 27 | 28 | 3. Add `~/.emacs.d/swish-lint` to your `PATH` 29 | 30 | 4. Run `swish-lint --version` to verify that it starts properly. 31 | 32 | ### Configure Emacs 33 | 34 | 1. Install [lsp-mode 8.0.0](https://emacs-lsp.github.io/lsp-mode/) 35 | 36 | 2. Install [lsp-ui 8.0.0](https://emacs-lsp.github.io/lsp-ui/) 37 | 38 | 3. Install [flycheck](https://www.flycheck.org/) - Flycheck version 31 39 | does not work properly with lsp-mode. We recommend either using the 40 | non-stable MELPA url `https://melpa.org/packages/` or another package 41 | management system to get a newer version. 42 | 43 | 4. Install [company-mode](http://company-mode.github.io/) 44 | 45 | You may also want to follow the [performance tuning instructions for 46 | lsp-mode](https://emacs-lsp.github.io/lsp-mode/page/performance/). As 47 | as starting point, add the following to your Emacs configuration, 48 | e.g., .emacs.d/init.el or .emacs file: 49 | 50 | ``` 51 | (require 'flycheck) 52 | 53 | (require 'company) 54 | (setq company-minimum-prefix-length 1) 55 | (setq company-idle-delay 0.0) 56 | 57 | (require 'lsp-mode) 58 | (setq lsp-prefer-capf t) 59 | (setq lsp-prefer-flymake nil) 60 | (setq lsp-enable-snippet nil) 61 | (setq lsp-idle-delay 0.100) 62 | 63 | (require 'lsp-ui) 64 | (add-hook 'lsp-mode-hook 'lsp-ui-mode) 65 | (add-hook 'scheme-mode-hook 'flycheck-mode) 66 | 67 | (setq gc-cons-threshold 100000000) 68 | (setq read-process-output-max (* 1024 1024)) 69 | 70 | (add-to-list 'load-path "~/.emacs.d/swish-lint") 71 | (add-to-list 'exec-path "~/.emacs.d/swish-lint") 72 | (require 'lsp-swish) 73 | ``` 74 | 75 | To use Swish-Lint's indentation, bind `swish-indent-sexp` in your 76 | scheme mode hook: 77 | 78 | ``` 79 | (add-hook 'scheme-mode-hook 80 | (function 81 | (lambda () 82 | (local-set-key (kbd "C-M-q") 'swish-indent-sexp)))) 83 | ``` 84 | 85 | ## Customize Configuration 86 | 87 | Swish-Lint provides user-level and project-level 88 | [configuration](configuration.md) to customize your experience. 89 | 90 | ## Design 91 | 92 | Swish-Lint uses a client/server architecture. The client provides the 93 | LSP support. The server maintains a central database called "The 94 | Tower". All good sourcerers keep their knowledge in a tower. 95 | 96 | Each time you open a new project, the client scans the code for 97 | definitions and references then updates the tower. This allows 98 | features like "goto definition" to jump from one code base to another. 99 | 100 | Swish-Lint attempts to deal with incomplete code. It reads your code 101 | using Chez Scheme's reader. When that fails, it attempts to extract 102 | identifiers using regular expressions. This means that "Find 103 | references" and highlighting may not provide lexical context or 104 | semantics you expect from the language itself. 105 | 106 | Swish-Lint generates a set of keywords to use for completions by 107 | invoking `swish`, `scheme`, and `petite` stopping upon success. Swish 108 | is not required, and can be removed from your `PATH` to run in a "Chez 109 | Scheme-Only mode". 110 | 111 | ## Diagnosing Problems 112 | 113 | ### Client-side 114 | 115 | Swish-Lint writes output to stderr which is available in a dedicated 116 | Emacs buffer. The output is helpful diagnosing protocol or performance 117 | problems. 118 | 119 | ### Server-side 120 | 121 | The tower uses an in-memory database and is automatically started when 122 | a client starts. An internal web server provides an aggregate view of 123 | client logs. See the logs here: http://localhost:51342/?limit=100 124 | 125 | Normally the tower's database is stored in memory only. If "goto 126 | definition" or "find references" provides unexpected behavior, you can 127 | start the tower manually and write the database to disk for analysis. 128 | 129 | The following command starts the tower, writes the database to disk, 130 | and writes diagnostic messages to the terminal: 131 | 132 | `./swish-lint --tower -v --tower-db tower.db3` 133 | 134 | ### Known Issues 135 | 136 | Performance can always be improved. 137 | 138 | "Find references" and "goto definition" apply trivial search 139 | rules. Lexical scope and language semantics are ignored. 140 | 141 | Chez Scheme's code can fool Swish-Lint. The Chez Scheme code is 142 | complex. Swish-Lint is simple. Your mileage will vary. 143 | -------------------------------------------------------------------------------- /checkers.ms: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2022 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (import 24 | (checkers) 25 | (config-params) 26 | (read) 27 | (software-info) 28 | (testing common) 29 | (testing pipe) 30 | ) 31 | 32 | (software-info:install) 33 | 34 | (define-syntax code 35 | (syntax-rules () 36 | [(_ str ...) 37 | (ct:join #\newline str ...)])) 38 | 39 | (isolate-mat import-export () 40 | (match-let* 41 | ([,results '()] 42 | [,text (code 43 | "(library (lib)" 44 | "(export (b) (a))" 45 | "(import (d) (c))" 46 | " body)")] 47 | [,_ 48 | (check-import/export (read-code text) 49 | (lambda (x type fmt . args) 50 | (set! results (cons (list x type (apply format fmt args)) results))))] 51 | [,results (reverse results)] 52 | [((`(annotation [stripped export]) warning "should sort exports") 53 | (`(annotation [stripped (b)]) info "incorrectly sorted: (b)") 54 | (`(annotation [stripped (a)]) info "incorrectly sorted: (a)") 55 | (`(annotation [stripped import]) warning "should sort imports") 56 | (`(annotation [stripped (d)]) info "incorrectly sorted: (d)") 57 | (`(annotation [stripped (c)]) info "incorrectly sorted: (c)")) 58 | results]) 59 | 'ok)) 60 | 61 | (isolate-mat line-whitespace () 62 | (match-let* 63 | ([,text (code 64 | "(let () " 65 | "\tbody\r" 66 | "\tbody " 67 | "...)\r")] 68 | [,results '()] 69 | [,_ 70 | (check-line-whitespace text #f 71 | (lambda (x type fmt . args) 72 | (set! results (cons (list x type (apply format fmt args)) results))))] 73 | [,results (reverse results)] 74 | [((2 error "undesirable tab character") 75 | (3 error "undesirable tab character") 76 | (2 error "undesirable DOS line ending") 77 | (4 error "undesirable DOS line ending") 78 | (1 error "undesirable trailing whitespace") 79 | (3 error "undesirable trailing whitespace")) 80 | results] 81 | [,results '()] 82 | [,_ 83 | (check-line-whitespace text #t 84 | (lambda (x type fmt . args) 85 | (set! results (cons (list x type (apply format fmt args)) results))))] 86 | [,results (reverse results)] 87 | [((2 error "undesirable tab character (2 times)") 88 | (2 error "undesirable DOS line ending (2 times)") 89 | (1 error "undesirable trailing whitespace (2 times)")) 90 | results]) 91 | 'ok)) 92 | 93 | (isolate-mat regexp () 94 | (match-let* 95 | ([,check (make-regexp-checker 'info "TEST.*")] 96 | [,results '()] 97 | [,_ 98 | (check "file:///tmp/foo.ss" #t #f 99 | (code 100 | "(let ()" 101 | " body ; TEST: simple" 102 | " body ; TEST: (printf \"~a\" 12)" 103 | " body ; TEST: ~a" 104 | " body)") 105 | (lambda (x type fmt . args) 106 | (set! results (cons (list x type (apply format fmt args)) results))))] 107 | [,results (reverse results)] 108 | [((#(range 2 12 2 24) info "TEST: simple") 109 | (#(range 3 12 3 34) info "TEST: (printf \"~a\" 12)") 110 | (#(range 4 12 4 20) info "TEST: ~a")) 111 | results]) 112 | 'ok)) 113 | 114 | (isolate-mat optional () 115 | (parameterize ([optional-checkers 116 | (list 117 | (make-regexp-checker 'info "INFO.*") 118 | (make-regexp-checker 'warning "WARNING.*") 119 | (make-regexp-checker 'error "ERROR.*"))]) 120 | (match-let* 121 | ([,results '()] 122 | [,_ 123 | (run-optional-checkers "file:///tmp/foo.ss" #t #f 124 | (code 125 | "(let ()" 126 | " body ; INFO: informative" 127 | " body ; WARNING: be careful" 128 | " body ; ERROR: this is broken" 129 | " body)") 130 | (lambda (x type fmt . args) 131 | (set! results (cons (list x type (apply format fmt args)) results))))] 132 | [,results (reverse results)] 133 | [((#(range 2 12 2 29) info "INFO: informative") 134 | (#(range 3 12 3 31) warning "WARNING: be careful") 135 | (#(range 4 12 4 33) error "ERROR: this is broken")) 136 | results]) 137 | 'ok))) 138 | 139 | (isolate-mat external () 140 | (with-tmp-dir 141 | ;; checker called with mismatched (filename regexp); executable is 142 | ;; not started 143 | (let ([fn (path-combine (tmp-dir) "dne")]) 144 | (match-let* 145 | ([,check (make-external-checker (list fn '(filename "\\.ms$")))] 146 | [,results '()] 147 | [,_ (check "file:///tmp/foo.ss" #t #f "" 148 | (lambda (x type fmt . args) 149 | (set! results (cons (list x type (apply format fmt args)) results))))] 150 | [() results]) 151 | 'ok)) 152 | ;; checker should report its command-line as a string 153 | (let ([fn (path-combine (tmp-dir) "echo-args-string")]) 154 | (write-script fn 155 | '((printf "args: ~s\n" (command-line-arguments)))) 156 | (match-let* 157 | ([,check (make-external-checker 158 | (list fn 159 | "--option" 160 | 'filename 161 | '(filename "\\.ss$")))] 162 | [,results '()] 163 | [,_ (check "file:///tmp/foo.ss" #t #f "" 164 | (lambda (x type fmt . args) 165 | (set! results (cons (list x type (apply format fmt args)) results))))] 166 | [,results (reverse results)] 167 | ;; strings report as errors 168 | [((1 error "args: (\"--option\" \"/tmp/foo.ss\" \"/tmp/foo.ss\")")) results]) 169 | (remove-file fn))) 170 | ;; checker should report its command-line as JSON 171 | (let ([fn (path-combine (tmp-dir) "echo-args-json")]) 172 | (write-script fn 173 | '((json:pretty 174 | (json:make-object 175 | [type "info"] 176 | [message (format "args: ~s" (command-line-arguments))])))) 177 | (match-let* 178 | ([,check (make-external-checker 179 | (list fn 180 | "--option" 181 | 'filename 182 | '(filename "\\.ss$")))] 183 | [,results '()] 184 | [,_ (check "file:///tmp/foo.ss" #t #f "" 185 | (lambda (x type fmt . args) 186 | (set! results (cons (list x type (apply format fmt args)) results))))] 187 | [,results (reverse results)] 188 | ;; JSON can configure its severity type 189 | [((#(near ,_ #f #f) info "args: (\"--option\" \"/tmp/foo.ss\" \"/tmp/foo.ss\")")) results]) 190 | (remove-file fn))) 191 | ;; checker reports multiple messages in JSON 192 | (let ([fn (path-combine (tmp-dir) "report-multiple-json")] 193 | [msg1 "A hint on line 2"] 194 | [msg2 "A warning on line 3"] 195 | [msg3 "An error on line 10, column 5"]) 196 | (write-script fn 197 | `((json:pretty 198 | (json:make-object 199 | [type "hint"] 200 | [line 2] 201 | [message ,msg1])) 202 | (json:pretty 203 | (json:make-object 204 | [type "warning"] 205 | [line 3] 206 | [message ,msg2])) 207 | (json:pretty 208 | (json:make-object 209 | ;; type defaults to error 210 | [column 5] 211 | [line 10] 212 | [message ,msg3])))) 213 | (match-let* 214 | ([,check (make-external-checker (list fn))] 215 | [,results '()] 216 | [,_ (check "file:///tmp/foo.ss" #t #f "" 217 | (lambda (x type fmt . args) 218 | (set! results (cons (list x type (apply format fmt args)) results))))] 219 | [,results (reverse results)] 220 | [((#(near ,_ 2 #f) hint ,@msg1) 221 | (#(near ,_ 3 #f) warning ,@msg2) 222 | (#(near ,_ 10 5) error ,@msg3)) 223 | results]) 224 | (remove-file fn))) 225 | ;; checker emits diagnostics on stderr, swish-lint sends that to 226 | ;; the trace-output-port. 227 | (let ([fn (path-combine (tmp-dir) "trace-output")] 228 | [diag-msg "this is a diagnostic message"] 229 | [err-msg "this is a message about the code"]) 230 | (write-script fn 231 | `((display ,diag-msg (current-error-port)) 232 | (newline (current-error-port)) 233 | (display ,err-msg (current-output-port)) 234 | (newline (current-output-port)) 235 | )) 236 | (match-let* 237 | ([,check (make-external-checker (list fn))] 238 | [,results '()] 239 | [(,tp ,get-trace) 240 | (let-values ([(p get) (open-string-output-port)]) 241 | (list p get))] 242 | [,_ 243 | (parameterize ([trace-output-port tp]) 244 | (check "file:///tmp/foo.ss" #t #f "" 245 | (lambda (x type fmt . args) 246 | (set! results (cons (list x type (apply format fmt args)) results)))))] 247 | [,results (reverse results)] 248 | [((1 error ,@err-msg)) results] 249 | ;; stderr is captured by the trace-output-port. 250 | ;; Use regexp here to ignore possible additional trace output 251 | ;; from SWISH_LINT_TRACE=yes. 252 | [#t (and (pregexp-match (pregexp-quote diag-msg) (get-trace)) #t)]) 253 | (remove-file fn))))) 254 | -------------------------------------------------------------------------------- /checkers.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (checkers) 24 | (export 25 | check-import/export 26 | check-line-whitespace 27 | make-external-checker 28 | make-regexp-checker 29 | run-optional-checkers 30 | ) 31 | (import 32 | (chezscheme) 33 | (config-params) 34 | (os-process) 35 | (read) 36 | (swish imports) 37 | (tower-client) 38 | (trace)) 39 | 40 | (define (run-optional-checkers uri skip-delay? annotated-code code report) 41 | (for-each 42 | (lambda (check) (check uri skip-delay? annotated-code code report)) 43 | (optional-checkers))) 44 | 45 | (define (check-import/export x report) 46 | (let lp ([x x]) 47 | (match x 48 | [`(annotation 49 | [stripped (library ,_ (export . ,_exports) . ,_rest)] 50 | [expression (,_library ,_ 51 | `(annotation 52 | [expression (,export.anno . ,exports.anno)]) 53 | . ,rest)]) 54 | (let* ([exports.anno 55 | (filter 56 | (lambda (x) 57 | (match x 58 | [`(annotation [stripped (rename . ,_)]) #f] 59 | [,_ #t])) 60 | exports.anno)] 61 | [exports (map annotation-stripped exports.anno)] 62 | [exports.orig (map (lambda (x) (format "~s" x)) exports)] 63 | [exports.sorted (sort string len 1) len)))])] 110 | [else 111 | (for-each 112 | (lambda (line) 113 | (report line 'error text)) 114 | lines)]))) 115 | (define tabs '()) 116 | (define dos '()) 117 | (define ws '()) 118 | (do ([ln 1 (+ ln 1)] 119 | [lines (split text #\newline) (cdr lines)]) 120 | ((null? lines)) 121 | (let* ([line (car lines)] 122 | [len (string-length line)]) 123 | (when (> len 0) 124 | (let lp ([i 0]) 125 | (when (< i len) 126 | (if (char=? (string-ref line i) #\tab) 127 | (set! tabs (cons ln tabs)) 128 | (lp (+ i 1))))) 129 | (let ([last-char (string-ref line (- len 1))]) 130 | (cond 131 | [(char=? last-char #\return) 132 | (set! dos (cons ln dos))] 133 | [(char-whitespace? last-char) 134 | (set! ws (cons ln ws))]))))) 135 | (yucky tabs "undesirable tab character") 136 | (yucky dos "undesirable DOS line ending") 137 | (yucky ws "undesirable trailing whitespace")) 138 | 139 | (define (make-regexp-checker type regexp) 140 | (define compiled-regexp (pregexp regexp)) 141 | (lambda (uri skip-delay? annotated-code code report) 142 | (do ([ln 1 (+ ln 1)] 143 | [lines (split code #\newline) (cdr lines)]) 144 | ((null? lines)) 145 | (let ([line (car lines)]) 146 | (let lp ([x (pregexp-match-positions compiled-regexp line)]) 147 | (match x 148 | [#f (void)] 149 | [() (void)] 150 | [((,start . ,end) . ,rest) 151 | ;; start and end are 0-based, but #(range ...) is 1-based 152 | (report `#(range ,ln ,(+ start 1) ,ln ,(+ end 1)) 153 | type 154 | "~a" 155 | (substring line start end)) 156 | (lp rest)])))))) 157 | 158 | (define (make-external-checker ls) 159 | (lambda (uri skip-delay? annotated-code code report) 160 | (define me self) 161 | (define (process-input ip pid) 162 | (let ([c (peek-char ip)]) 163 | (unless (eof-object? c) 164 | (cond 165 | [(char-whitespace? c) 166 | (get-char ip) 167 | (process-input ip pid)] 168 | [(char=? c #\{) 169 | (send me `#(process-json ,(json:read ip)))] 170 | [else 171 | (let ([inp (trim-whitespace (get-line ip))]) 172 | (unless (string=? inp "") 173 | (send me `#(process-error ,inp))))]) 174 | (process-input ip pid)))) 175 | (define (process-stderr ip pid) 176 | (let ([line (get-line ip)]) 177 | (unless (eof-object? line) 178 | (display line (trace-output-port)) 179 | (newline (trace-output-port)) 180 | (process-stderr ip pid)))) 181 | (define (run-command cmd) 182 | (trace-time `(run-external-checker ,@cmd) 183 | (match (os-process:start&link (car cmd) (cdr cmd) 'utf8 184 | process-input #f process-stderr) 185 | [#(error ,reason) 186 | (throw reason)] 187 | [#(ok ,pid) 188 | (let ([m (monitor pid)]) 189 | (let lp ([lookup-table #f]) 190 | (receive (after 5000 191 | (kill pid 'shutdown) 192 | (receive (after 5000 193 | (kill pid 'kill) 194 | (receive 195 | [`(DOWN ,@m ,_ ,_ ,err) 196 | (throw err)])) 197 | [`(DOWN ,@m ,_ ,_ ,err) 198 | (throw err)])) 199 | [#(process-error ,str) 200 | (let ([lookup-table (or lookup-table (make-code-lookup-table code))]) 201 | (let-values ([(line msg) (reason->line/msg str lookup-table)]) 202 | (report line 'error "~a" msg) 203 | (lp lookup-table)))] 204 | [#(process-json ,obj) 205 | (let* ([msg (json:ref obj 'message #f)] 206 | [type (match (json:ref obj 'type #f) 207 | ["info" 'info] 208 | ["hint" 'hint] 209 | ["warning" 'warning] 210 | [,_ 'error])] 211 | [line (json:ref obj 'line #f)] 212 | [line (and line (fixnum? line) (fxpositive? line) line)] 213 | [col (json:ref obj 'column #f)] 214 | [col (and col (fixnum? col) (fxpositive? col) col)]) 215 | (when msg 216 | (report `#(near ,code ,line ,col) type "~a" msg)) 217 | (lp lookup-table))] 218 | [`(DOWN ,@m ,_ ,reason) 219 | (unless (eq? reason 'normal) 220 | (trace-expr `(external-checker ,(exit-reason->english reason))))])))]))) 221 | (when skip-delay? ; recently saved 222 | (let* ([filename 223 | (if (starts-with? uri "file:") 224 | (uri->abs-path uri) 225 | uri)] 226 | [cmd (fold-right 227 | (lambda (x acc) 228 | (and acc 229 | (match x 230 | [filename (cons filename acc)] 231 | [(filename ,re) 232 | (if (pregexp-match re (path-last filename)) 233 | (cons filename acc) 234 | #f)] 235 | [,_ (cons x acc)]))) 236 | '() 237 | ls)]) 238 | (when cmd ; skip the file if the filename regexp fails 239 | (run-command cmd)))))) 240 | ) 241 | -------------------------------------------------------------------------------- /config-params.ss: -------------------------------------------------------------------------------- 1 | (library (config-params) 2 | (export 3 | config:definition-keywords 4 | config:find-files 5 | optional-checkers 6 | ) 7 | (import 8 | (chezscheme) 9 | (swish imports) 10 | ) 11 | ;; Project-level 12 | (define config:definition-keywords (make-parameter '())) 13 | 14 | ;; User-level 15 | (define optional-checkers (make-parameter '())) 16 | 17 | (define config:find-files (make-parameter #f)) 18 | ) 19 | -------------------------------------------------------------------------------- /config.ss: -------------------------------------------------------------------------------- 1 | (library (config) 2 | (export 3 | config-output-port 4 | config:load-project 5 | config:load-user 6 | config:user-dir 7 | make-optional-passes 8 | output-env 9 | ) 10 | (import 11 | (checkers) 12 | (chezscheme) 13 | (config-params) 14 | (swish imports) 15 | ) 16 | (define config-output-port 17 | (make-parameter 18 | (make-custom-textual-output-port "bit-sink port" 19 | (lambda (str start n) n) #f #f #f))) 20 | 21 | (define (output-env) 22 | (cond 23 | [(getenv "XDG_CONFIG_HOME") => 24 | (lambda (home) 25 | (fprintf (config-output-port) "XDG_CONFIG_HOME: ~a\n" home))] 26 | [(getenv "HOME") => 27 | (lambda (home) 28 | (fprintf (config-output-port) "HOME: ~a\n" home))] 29 | [else 30 | (fprintf (config-output-port) "Neither HOME nor XDG_CONFIG_HOME are set\n")])) 31 | 32 | (define (load-config who path process-expr) 33 | (cond 34 | [(file-exists? path) 35 | (fprintf (config-output-port) "Found ~a configuration: ~a\n" who path) 36 | (match (try 37 | (let ([ip (open-file-to-read path)]) 38 | (on-exit (close-port ip) 39 | (let lp () 40 | (let ([x (read ip)]) 41 | (if (eof-object? x) 42 | '() 43 | (cons x (lp)))))))) 44 | [`(catch ,reason) 45 | (fprintf (config-output-port) "~a: ~a\n" who (exit-reason->english reason))] 46 | [,exprs 47 | (for-each 48 | (lambda (expr) 49 | (match (try (process-expr expr)) 50 | [`(catch ,reason) 51 | (fprintf (config-output-port) "~a: ~a\n" who (exit-reason->english reason))] 52 | [,_ (void)])) 53 | exprs)])] 54 | [else 55 | (fprintf (config-output-port) "~:(~a~) configuration not found: ~a\n" who path)])) 56 | 57 | (define (config:load-project path) 58 | (let ([fn (path-combine path ".swish" "swish-lint.ss")]) 59 | (load-config 'project fn 60 | (lambda (expr) 61 | (match expr 62 | [(definition-keywords . ,ls) 63 | (unless (for-all string? ls) 64 | (throw "definition-keywords must all be strings")) 65 | (config:definition-keywords ls)] 66 | [,_ 67 | (fprintf (config-output-port) "project: ignoring ~a\n" expr)]))))) 68 | 69 | (define (config:user-dir) 70 | (cond 71 | [(getenv "XDG_CONFIG_HOME")] 72 | [(getenv "HOME") => 73 | (lambda (home) (path-combine home ".config"))] 74 | [else #f])) 75 | 76 | (define (config:load-user) 77 | (cond 78 | [(config:user-dir) => 79 | (lambda (path) 80 | (let ([fn (path-combine path "swish" "swish-lint.ss")]) 81 | (load-config 'user fn 82 | (lambda (expr) 83 | (match expr 84 | [(find-files . ,(ls <= (,cmd . ,args))) 85 | (unless (for-all string? ls) 86 | (throw "find-files must all be strings")) 87 | (config:find-files ls)] 88 | [(optional-checkers . ,ls) 89 | (optional-checkers (append (optional-checkers) (make-optional-passes ls)))] 90 | [,_ 91 | (fprintf (config-output-port) "user: ignoring ~a\n" expr)])))))])) 92 | 93 | (define (make-optional-passes ls) 94 | (let lp ([ls ls] [acc '()]) 95 | (match ls 96 | [() (reverse acc)] 97 | [((external . ,(ls <= (,cmd . ,args))) . ,rest) 98 | (guard 99 | (for-all 100 | (lambda (x) 101 | (match x 102 | [filename #t] 103 | [(filename ,re) (guard (string? re)) #t] 104 | [,_ (string? x)])) 105 | ls)) 106 | (lp rest (cons (make-external-checker ls) acc))] 107 | [((regexp ,type ,regexp) . ,rest) 108 | (guard (member type '("info" "warning" "error"))) 109 | (lp rest 110 | (cons (make-regexp-checker (string->symbol type) regexp) acc))] 111 | [(,clause . ,_) 112 | (errorf 'make-optional-passes "invalid clause: ~a" clause)]))) 113 | ) 114 | -------------------------------------------------------------------------------- /configuration.md: -------------------------------------------------------------------------------- 1 | # Configuration 2 | 3 | A user may customize how Swish-Lint runs personally, or for a whole project. 4 | 5 | When creating a new configuration or an external checker, it is useful to set the environment variable `SWISH_LINT_TRACE=yes` and run from the command-line to get additional diagnostics on stderr. 6 | 7 | ## User-level 8 | 9 | When interacting in an editor, user-level configuration is loaded by default. If the system defines `XDG_CONFIG_HOME`, Swish-Lint searches for user-level configuration in `XDG_CONFIG_HOME/swish/swish-lint.ss`. Alternatively, if `HOME` is defined, it loads the configuration from `HOME/.config/swish/swish-lint.ss`. 10 | 11 | For consistent results at the command-line and on build systems, user-level configuration is not considered by default and must be enabled explicitly with the `--user-config` option. 12 | 13 | ### `(find-files cmd . args)` 14 | 15 | By default, Swish-Lint recursively searches through a project's directories seeking `*.ss` and `*.ms` files while ignoring `.git` directories. However, it can be advantageous to customize this behavior to utilizing an external program like `git`, as demonstrated below: 16 | 17 | ```scheme 18 | (find-files "git" "ls-files" "--" "*.ss" "*.ms") 19 | ``` 20 | 21 | ### `(optional-checkers e0 e1 ...)` 22 | 23 | There are parameterizable checkers in the system. Regular expressions or external programs may be used to augment Swish-Lint's results. 24 | 25 | #### `(regexp type expr)` 26 | 27 | This form checks for a single regular expression and reports lint of a specific type. `type` is one of `"info"`, `"warning"`, `"error"`. `expr` is a regular expression. 28 | 29 | ```scheme 30 | (optional-checkers 31 | (regexp "info" "TODO.*")) 32 | ``` 33 | 34 | #### `(external cmd . args)` 35 | 36 | After saving a file, Swish-Lint may spawn an external process to perform additional checks. The external program should be able to ignore most of the details of LSP to focus on the specific task at hand. 37 | 38 | Swish-Lint will replace references to the symbol `filename` within `args` with the filename to check. Alternately, `(filename regexp)` can be used. The checker will only run if the filename matches the provided `regexp`. 39 | 40 | The external process may emit single lines of output. Swish-Lint attempts to extract exception text and source information as if an exception was generated from Chez Scheme. These messages are always reported as errors. 41 | 42 | The external process may emit JSON objects. Each JSON object may contain the following fields: `message`, `type`, `line`, `column`. 43 | 44 | `message` (required) is a string to present to the user. 45 | 46 | `type` (optional) is a one of `"info"`, `"hint"`, `"warning"`, `"error"`. `type` defaults to `"error"`. 47 | 48 | `line` (optional) and `column` (optional) are 1-based indexes. These ignore the complexities of LSP's UTF-16 code point counting. 49 | 50 | ```scheme 51 | (optional-checkers 52 | (external "my-checker" "--load" filename)) 53 | ``` 54 | 55 | As an example, a simple my-checker program might look like the following: 56 | 57 | ```scheme 58 | #!/usr/bin/env swish 59 | 60 | (json:pretty 61 | (json:make-object 62 | [type "info"] 63 | [message (format "args: ~s" (command-line-arguments))])) 64 | ``` 65 | 66 | ## Project-level 67 | 68 | Swish-Lint looks for project-level configuration at the top-level of the current repository in `.swish/swish-lint.ss`. 69 | 70 | ### `(definition-keywords kwd ...)` 71 | 72 | In a project, macros have the ability to create definitions. Swish-Lint provides the `definition-keywords` option to 73 | enable navigation to these definitions. Each `kwd` is recognized as a definition for the identifier that follows it in a form analogous to `(define x ...)`, `(define (x ...) ...)`, or the `meta` or `trace-define` variations of these. 74 | 75 | For example, in an object-oriented system, macros of the form `(class id body ...)` or `(interface id body ...)` a project may specify the following: 76 | 77 | ``` scheme 78 | (definition-keywords "class" "interface") 79 | ``` 80 | -------------------------------------------------------------------------------- /copy-dlls: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env swish 2 | 3 | ;;; Copyright 2020 Beckman Coulter, Inc. 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | ;;; 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | ;;; 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE. 24 | 25 | (define cli 26 | (cli-specs 27 | default-help 28 | [scheme -s (string "") "the path to Chez Scheme's binary directory" 29 | (usage req)])) 30 | 31 | (define opt (parse-command-line-arguments cli)) 32 | 33 | (when (opt 'help) 34 | (display-help (app:name) cli (opt)) 35 | (exit 0)) 36 | 37 | (unless (memq (machine-type) '(a6nt i3nt)) 38 | (exit 0)) 39 | 40 | (unless (opt 'scheme) 41 | (errorf #f "-s is required")) 42 | 43 | (define (ctime fn) 44 | (match (get-stat fn) 45 | [`( [ctime (,sec . ,nsec)]) (make-time 'time-duration nsec sec)] 46 | [,_ #f])) 47 | 48 | (define (copy-file in out) 49 | (and (file-exists? in) 50 | (let* ([bv (read-file in)] 51 | [op (open-file out (+ O_WRONLY O_CREAT O_TRUNC) #o777 'binary-output)]) 52 | (on-exit (close-port op) 53 | (put-bytevector op bv)) 54 | #t))) 55 | 56 | (define (maybe-copy-file src-dir fn) 57 | (let ([in (path-combine src-dir fn)] 58 | [out fn]) 59 | (and (file-exists? in) 60 | (let ([in-time (ctime in)] 61 | [out-time (ctime out)]) 62 | (and (or (not out-time) (time>? in-time out-time)) 63 | (copy-file in out)))))) 64 | 65 | (define swish-libdir (path-parent (osi_get_executable_path))) 66 | 67 | (define csvNNN.dll 68 | (format "csv~{~a~}.dll" 69 | (call-with-values scheme-version-number list))) 70 | 71 | (for-each 72 | (lambda (fn) (maybe-copy-file swish-libdir fn)) 73 | '("uv.dll" "sqlite3.dll" "osi.dll")) 74 | 75 | (or (maybe-copy-file swish-libdir csvNNN.dll) 76 | (maybe-copy-file (opt 'scheme) csvNNN.dll)) 77 | -------------------------------------------------------------------------------- /cursor.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2022 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (library (cursor) 25 | (export 26 | cursor->string 27 | cursor-line 28 | cursor:copy 29 | cursor:goto-line! 30 | line-str 31 | lsp:change-content 32 | string->cursor 33 | trace-cursor 34 | ) 35 | (import 36 | (chezscheme) 37 | (json) 38 | (swish imports) 39 | (trace) 40 | ) 41 | (define string-append+ 42 | (case-lambda 43 | [(a b) 44 | (let ([a? (not (equal? a ""))] 45 | [b? (not (equal? b ""))]) 46 | (cond 47 | [(not a?) b] 48 | [(not b?) a] 49 | [else (string-append a b)]))] 50 | [(a b c) 51 | (let ([a? (not (equal? a ""))] 52 | [b? (not (equal? b ""))] 53 | [c? (not (equal? c ""))]) 54 | (cond 55 | [(not a?) 56 | (cond 57 | [(not b?) c] 58 | [(not c?) b] 59 | [else (string-append b c)])] 60 | [(not b?) 61 | (cond 62 | [(not c?) a] 63 | [else (string-append a c)])] 64 | [(not c?) 65 | (string-append a b)] 66 | [else 67 | (string-append a b c)]))])) 68 | 69 | (define (single-line? s) 70 | (let lp ([i (fx- (string-length s) 1)]) 71 | (cond 72 | [(fx< i 0) #t] 73 | [(char=? (string-ref s i) #\newline) #f] 74 | [else (lp (fx1- i))]))) 75 | 76 | (define-record-type line 77 | (nongenerative) 78 | (sealed #t) 79 | (fields 80 | (immutable str) 81 | (mutable prev) 82 | (mutable next)) 83 | (protocol 84 | (lambda (new) 85 | (lambda (str) 86 | (new str #f #f))))) 87 | 88 | (define-record-type cursor 89 | (nongenerative) 90 | (sealed #t) 91 | (fields 92 | (mutable line) 93 | (mutable index$)) ; 0-based index 94 | (protocol 95 | (lambda (new) 96 | (lambda (first-line) 97 | (new first-line 0))))) 98 | 99 | (define (cursor-index c) 100 | (or (cursor-index$ c) 101 | (let lp ([x (line-prev (cursor-line c))] [index 0]) 102 | (cond 103 | [(not x) 104 | (cursor-index$-set! c index) 105 | index] 106 | [else 107 | (lp (line-prev x) (fx1+ index))])))) 108 | 109 | (define (cursor:copy c) 110 | (make-cursor 111 | (let* ([old (first-line (cursor-line c))] 112 | [first (make-line (line-str old))]) 113 | (line-next-set! first 114 | (let lp ([old (line-next old)] [p first]) 115 | (cond 116 | [(not old) #f] 117 | [else 118 | (let ([new (make-line (line-str old))]) 119 | (line-prev-set! new p) 120 | (line-next-set! new (lp (line-next old) new)) 121 | new)]))) 122 | first))) 123 | 124 | (define (insert-after! line text) 125 | (let ([new (make-line text)]) 126 | (line-prev-set! new line) 127 | (when line 128 | (let ([next (line-next line)]) 129 | (line-next-set! new next) 130 | (line-next-set! line new) 131 | (when next 132 | (line-prev-set! next new)))) 133 | new)) 134 | 135 | (define (replace! c line1 line2 prefix text suffix) 136 | (cond 137 | [(single-line? text) 138 | (let ([new (make-line (string-append+ prefix text suffix))] 139 | [prev (line-prev line1)] 140 | [next (line-next line2)]) 141 | (when prev 142 | (line-next-set! prev new)) 143 | (when next 144 | (line-prev-set! next new)) 145 | (line-prev-set! new prev) 146 | (line-next-set! new next) 147 | ;; No need to update cursor index 148 | (cursor-line-set! c new) 149 | c)] 150 | [else 151 | (let* ([prev (line-prev line1)] 152 | [next (line-next line2)] 153 | [text-lines (split text #\newline)] 154 | [first (make-line (string-append+ prefix (car text-lines)))] 155 | [last #f] 156 | [rest 157 | (let lp ([ls (cdr text-lines)] [p first]) 158 | (match ls 159 | [(,str) 160 | (let ([new (make-line (string-append+ str suffix))]) 161 | (line-prev-set! new p) 162 | (line-next-set! new next) 163 | (set! last new) 164 | new)] 165 | [(,str . ,rest) 166 | (let ([new (make-line str)]) 167 | (line-prev-set! new p) 168 | (line-next-set! new (lp rest new)) 169 | new)]))]) 170 | (when prev 171 | (line-next-set! prev first)) 172 | (when next 173 | (line-prev-set! next last)) 174 | (line-prev-set! first prev) 175 | (line-next-set! first rest) 176 | ;; No need to update cursor index 177 | (cursor-line-set! c first) 178 | c)])) 179 | 180 | (define (move-down line n) 181 | (if (= n 0) 182 | line 183 | (move-down (line-next line) (- n 1)))) 184 | 185 | (define (move-up line n) 186 | (if (= n 0) 187 | line 188 | (move-up (line-prev line) (- n 1)))) 189 | 190 | (define (first-line line) 191 | (let ([prev (line-prev line)]) 192 | (if prev 193 | (first-line prev) 194 | line))) 195 | 196 | (define (last-line line) 197 | (let ([next (line-next line)]) 198 | (if next 199 | (last-line next) 200 | line))) 201 | 202 | (define (cursor:goto-line! c line0) 203 | (let* ([i (cursor-index c)] 204 | [delta (- line0 i)]) 205 | (cond 206 | [(zero? delta)] 207 | [(positive? delta) 208 | (cursor-line-set! c (move-down (cursor-line c) delta)) 209 | (cursor-index$-set! c line0)] 210 | [else 211 | (cursor-line-set! c (move-up (cursor-line c) (abs delta))) 212 | (cursor-index$-set! c line0)]) 213 | c)) 214 | 215 | (define (ip->lines ip) 216 | (let lp ([acc (make-line (get-line ip))]) 217 | (let ([line (get-line ip)]) 218 | (if (eof-object? line) 219 | (insert-after! acc "") 220 | (lp (insert-after! acc line)))))) 221 | 222 | (define (string->cursor text) 223 | (make-cursor 224 | (if (equal? text "") 225 | (make-line "") 226 | (first-line (ip->lines (open-input-string text)))))) 227 | 228 | (define (cursor->string c) 229 | (let ([op (open-output-string)]) 230 | (let lp ([line (first-line (cursor-line c))]) 231 | (when line 232 | (let ([str (line-str line)] 233 | [next (line-next line)]) 234 | (display-string str op) 235 | (when (or next (not (equal? str ""))) 236 | (newline op)) 237 | (lp next)))) 238 | (get-output-string op))) 239 | 240 | (define (lsp:change-content cursor deltas) 241 | (fold-left 242 | (lambda (cursor delta) 243 | (let ([text (json:get delta 'text)] 244 | [range (json:ref delta 'range #f)]) 245 | (cond 246 | [range 247 | (let* ([start (json:get range 'start)] 248 | [end (json:get range 'end)] 249 | [sl (json:get start 'line)] 250 | [sc (json:get start 'character)] 251 | [el (json:get end 'line)] 252 | [ec (json:get end 'character)] 253 | [_ (cursor:goto-line! cursor sl)] 254 | [line1 (cursor-line cursor)] 255 | [sstr (line-str line1)] 256 | [slen (string-length sstr)] 257 | [prefix (substring sstr 0 (min sc slen))] 258 | [line2 (move-down line1 (- el sl))] 259 | [estr (line-str line2)] 260 | [elen (string-length estr)] 261 | [suffix (substring estr (min ec elen) elen)]) 262 | (replace! cursor line1 line2 prefix text suffix))] 263 | [else 264 | (string->cursor text)]))) 265 | cursor 266 | deltas)) 267 | 268 | (define (trace-cursor cursor) 269 | (define ln (cursor-index cursor)) 270 | (when trace? 271 | (let lp ([n 0] [line (first-line (cursor-line cursor))]) 272 | (when line 273 | (fprintf (trace-output-port) "~a~d: ~a\n" (if (= n ln) "*" " ") n (line-str line)) 274 | (lp (+ n 1) (line-next line)))) 275 | (newline (trace-output-port)) 276 | (flush-output-port (trace-output-port))) 277 | cursor) 278 | ) 279 | 280 | #!eof mats 281 | 282 | (load-this-exposing 283 | '(cursor-index cursor-index$ cursor-index$-set! 284 | first-line last-line line-next 285 | string-append+ 286 | )) 287 | 288 | (import 289 | (cursor) 290 | (software-info)) 291 | 292 | (software-info:install) 293 | 294 | (define (make-pos line char) 295 | (json:make-object [line line] [character char])) 296 | 297 | (define (make-range start end) 298 | (json:make-object [start start] [end end])) 299 | 300 | (define (check-doc cursor expected) 301 | (let ([index (cursor-index$ cursor)]) 302 | (cond 303 | [index 304 | (cursor-index$-set! cursor #f) 305 | (let ([expected (cursor-index cursor)]) 306 | (unless (equal? expected index) 307 | (throw `#(mismatched-index ,expected ,index))))] 308 | [else 309 | (printf "there is not an index\n")])) 310 | 311 | (trace-cursor cursor) 312 | (let lp ([n 1] [line (first-line (cursor-line cursor))] [exp (split expected #\newline)]) 313 | (cond 314 | [line 315 | (match exp 316 | [() (throw `#(line-without-expected ,(line-str line)))] 317 | [(,exp . ,rest) 318 | (unless (equal? (line-str line) exp) 319 | (printf "> ~a: ~a\n" n exp) 320 | (printf "< ~a: ~a\n" n (line-str line)) 321 | (throw `#(mismatch ,exp ,(line-str line)))) 322 | (lp (+ n 1) (line-next line) rest)])] 323 | [else 324 | (unless (null? exp) 325 | (throw `#(expected-without-line ,(car exp))))])) 326 | 327 | (let ([flip (cursor->string (string->cursor expected))]) 328 | (unless (equal? expected flip) 329 | (throw 'round-trip-failed))) 330 | 331 | ;; Moving all the way down and back up should yield the same object 332 | (let ([line (cursor-line cursor)]) 333 | (unless (eq? (first-line line) (first-line (last-line line))) 334 | (throw 'incorrect-structure))) 335 | ) 336 | 337 | (isolate-mat string-append+ () 338 | (match-let* 339 | ([,a "a"] 340 | [,b "b"] 341 | [,c "c"] 342 | [#t (eq? a (string-append+ a ""))] 343 | [#t (eq? b (string-append+ "" b))] 344 | ["ab" (string-append+ a b)] 345 | ["" (string-append+ "" "")] 346 | [#t (eq? a (string-append+ a "" ""))] 347 | [#t (eq? b (string-append+ "" b ""))] 348 | [#t (eq? c (string-append+ "" "" c))] 349 | ["ab" (string-append+ a b "")] 350 | ["ac" (string-append+ a "" c)] 351 | ["bc" (string-append+ "" b c)] 352 | ["abc" (string-append+ a b c)] 353 | ["" (string-append+ "" "" "")]) 354 | 'ok)) 355 | 356 | (isolate-mat edit-line () 357 | (define (perform-edits ls) 358 | (match-let* 359 | ([,start (string-append "\n" (make-string (+ (apply max ls) 1) #\*) "\n")] 360 | [,doc (string->cursor start)] 361 | [,_ (check-doc doc start)] 362 | [,doc 363 | (fold-left 364 | (lambda (doc n) 365 | (lsp:change-content doc 366 | (list 367 | (json:make-object 368 | [text (format "~d" n)] 369 | [range 370 | (make-range 371 | (make-pos 1 n) 372 | (make-pos 1 (+ n 1)))])))) 373 | doc 374 | ls)] 375 | [,_ (check-doc doc (format "\n~{~a~}\n" (sort < ls)))]) 376 | 'ok)) 377 | (perform-edits '(0 1 2 3 4 5)) 378 | (perform-edits '(5 4 3 2 1 0)) 379 | (perform-edits '(0 3 2 5 1 4))) 380 | 381 | (isolate-mat edit-lines () 382 | (define (perform-edits ls) 383 | (match-let* 384 | ([,start (format "~{*** ~a ***\n~}" (iota (+ (apply max ls) 1)))] 385 | [,doc (string->cursor start)] 386 | [,_ (check-doc doc start)] 387 | [,doc 388 | (fold-left 389 | (lambda (doc n) 390 | (lsp:change-content doc 391 | (list 392 | (json:make-object 393 | [text (format "~d\n" n)] 394 | [range 395 | (make-range 396 | (make-pos n 0) 397 | (make-pos (+ n 1) 0))])))) 398 | doc 399 | ls)] 400 | [,_ (check-doc doc (format "~{~a\n~}" (sort < ls)))]) 401 | 'ok)) 402 | (perform-edits '(0 1 2 3 4 5)) 403 | (perform-edits '(5 4 3 2 1 0)) 404 | (perform-edits '(0 3 2 5 1 4))) 405 | 406 | (isolate-mat insert-multiple-lines () 407 | (define (perform-edits ls) 408 | (match-let* 409 | ([,start (format "~{*** ~a ***\n~}" (iota (* (+ (apply max ls) 1) 2)))] 410 | [,doc (string->cursor start)] 411 | [,_ (check-doc doc start)] 412 | [,doc 413 | (fold-left 414 | (lambda (doc n) 415 | (lsp:change-content doc 416 | (list 417 | (json:make-object 418 | [text (format "~d\nbonus\n" n)] 419 | [range 420 | (make-range 421 | (make-pos (* n 2) 0) 422 | (make-pos (+ (* n 2) 2) 0))])))) 423 | doc 424 | ls)] 425 | [,_ (check-doc doc (format "~{~a\nbonus\n~}" (sort < ls)))]) 426 | 'ok)) 427 | (perform-edits '(0 1 2 3 4 5)) 428 | (perform-edits '(5 4 3 2 1 0)) 429 | (perform-edits '(0 3 2 5 1 4))) 430 | 431 | (isolate-mat basic () 432 | (match-let* 433 | ([,start "(let ()\n (+ x y))\n"] 434 | [,doc (string->cursor start)] 435 | [,_ (check-doc doc start)] 436 | [,doc (lsp:change-content doc 437 | (list 438 | (json:make-object 439 | [text "a"] 440 | [range 441 | (make-range 442 | (make-pos 0 0) 443 | (make-pos 0 0))])))] 444 | [,_ (check-doc doc (string-append "a" start))] 445 | [,doc (lsp:change-content doc 446 | (list 447 | (json:make-object 448 | [text ""] 449 | [range 450 | (make-range 451 | (make-pos 0 0) 452 | (make-pos 0 1))])))] 453 | [,_ (check-doc doc start)] 454 | [,doc (lsp:change-content doc 455 | (list 456 | (json:make-object 457 | [text ""] 458 | [range 459 | (make-range 460 | (make-pos 0 4) 461 | (make-pos 1 9))])))] 462 | [,_ (check-doc doc "(let)\n")] 463 | [,doc (lsp:change-content doc 464 | (list 465 | (json:make-object 466 | [text " ()\n (+ x y)"] 467 | [range 468 | (make-range 469 | (make-pos 0 4) 470 | (make-pos 0 4))])))] 471 | [,doc (lsp:change-content doc 472 | (list 473 | (json:make-object 474 | [text " ()\n (+ x y)"] 475 | [range 476 | (make-range 477 | (make-pos 0 4) 478 | (make-pos 1 9))])))] 479 | [,doc (lsp:change-content doc 480 | (list 481 | (json:make-object 482 | [text ")"] 483 | [range 484 | (make-range 485 | (make-pos 1 8) 486 | (make-pos 1 9))])))] 487 | [,_ (check-doc doc start)] 488 | 489 | [,doc (lsp:change-content doc 490 | (list 491 | (json:make-object 492 | [text "abc\n"] 493 | [range 494 | (make-range 495 | (make-pos 2 0) 496 | (make-pos 2 0))])))] 497 | [,_ (check-doc doc (string-append start "abc\n"))] 498 | 499 | [,doc (lsp:change-content doc 500 | (list 501 | (json:make-object 502 | [text ""] 503 | [range 504 | (make-range 505 | (make-pos 2 0) 506 | (make-pos 2 3))])))] 507 | [,_ (check-doc doc (string-append start "\n"))] 508 | [,doc (lsp:change-content doc 509 | (list 510 | (json:make-object 511 | [text ""] 512 | [range 513 | (make-range 514 | (make-pos 2 0) 515 | (make-pos 3 0))])))] 516 | [,_ (check-doc doc start)] 517 | [,doc (lsp:change-content doc 518 | (list 519 | (json:make-object 520 | [text ""])))] 521 | [,_ (check-doc doc "")] 522 | [,doc (lsp:change-content doc 523 | (list 524 | (json:make-object 525 | [text "abc\n"])))] 526 | [,_ (check-doc doc "abc\n")] 527 | ) 528 | 'ok)) 529 | -------------------------------------------------------------------------------- /doc.ss: -------------------------------------------------------------------------------- 1 | (library (doc) 2 | (export 3 | doc:get-text 4 | doc:get-value-near 5 | doc:start 6 | doc:start&link 7 | doc:updated 8 | ) 9 | (import 10 | (chezscheme) 11 | (cursor) 12 | (read) 13 | (swish imports) 14 | (trace) 15 | ) 16 | 17 | (define-state-tuple cursor worker-pid on-changed) 18 | 19 | (define (init on-changed) 20 | `#(ok ,( make 21 | [cursor #f] 22 | [worker-pid #f] 23 | [on-changed on-changed]))) 24 | 25 | (define (terminate reason state) 'ok) 26 | 27 | (define (handle-call msg from state) 28 | (match msg 29 | [get-text 30 | `#(reply ,(cursor->string ($state cursor)) ,state)] 31 | [#(get-value-near ,line1 ,char1) 32 | (trace-time `(get-value-near ,line1 ,char1) 33 | (let* ([cursor (cursor:goto-line! ($state cursor) (fx- line1 1))] 34 | [text (line-str (cursor-line cursor))]) 35 | (match (try 36 | (let-values ([(type value bfp efp) 37 | (read-token-near/col text char1)]) 38 | (and (eq? type 'atomic) 39 | (match value 40 | [,_ (guard (symbol? value)) 41 | (get-symbol-name value)] 42 | [($primitive ,value) 43 | (get-symbol-name value)] 44 | [($primitive ,_ ,value) 45 | (get-symbol-name value)] 46 | [,_ #f])))) 47 | [`(catch ,reason) 48 | (trace-expr 49 | `(get-value-near ,line1 ,char1 => ,(exit-reason->english reason))) 50 | `#(reply #f ,state)] 51 | ["" `#(reply #f ,state)] 52 | [,result 53 | `#(reply ,result ,state)])))])) 54 | 55 | (define (handle-cast msg state) 56 | (match msg 57 | [#(updated ,change ,skip-delay?) 58 | (let ([pid ($state worker-pid)]) 59 | (when pid (kill pid 'cancelled))) 60 | (let ([cursor 61 | (cond 62 | [(not change) (string->cursor "")] 63 | [(string? change) (string->cursor change)] 64 | [else (lsp:change-content ($state cursor) change)])]) 65 | (cond 66 | [($state on-changed) => 67 | (lambda (on-changed) 68 | (let ([pid (on-changed change (cursor:copy cursor) skip-delay?)]) 69 | (monitor pid) 70 | `#(no-reply 71 | ,($state copy 72 | [cursor cursor] 73 | [worker-pid pid]))))] 74 | [else 75 | `#(no-reply ($state copy [cursor cursor]))]))])) 76 | 77 | (define (handle-info msg state) 78 | (match msg 79 | [`(DOWN ,_ ,pid ,reason) 80 | (cond 81 | [(eq? pid ($state worker-pid)) 82 | (unless (eq? reason 'normal) 83 | (trace-expr `(doc-worker ,(exit-reason->english reason)))) 84 | `#(no-reply ,($state copy [worker-pid #f]))] 85 | [else 86 | `#(no-reply ,state)])])) 87 | 88 | (define (doc:start&link on-changed) 89 | (gen-server:start&link #f on-changed)) 90 | 91 | (define (doc:start on-changed) 92 | (gen-server:start #f on-changed)) 93 | 94 | (define (doc:get-text who) 95 | (gen-server:call who 'get-text)) 96 | 97 | (define (doc:get-value-near who line1 char1) 98 | (gen-server:call who `#(get-value-near ,line1 ,char1))) 99 | 100 | (define (doc:updated who change skip-delay?) 101 | (gen-server:cast who `#(updated ,change ,skip-delay?))) 102 | ) 103 | -------------------------------------------------------------------------------- /flycheck.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (flycheck) 24 | (export 25 | compile-format 26 | flycheck:process-file 27 | report-format 28 | ) 29 | (import 30 | (checkers) 31 | (chezscheme) 32 | (read) 33 | (swish imports) 34 | ) 35 | 36 | (define current-filename (make-parameter #f)) 37 | (define current-source-table (make-parameter #f)) 38 | (define report-format (make-parameter #f)) 39 | 40 | (define (compile-format fmt-str) 41 | (let lp ([offset 0] [acc '()]) 42 | (match (pregexp-match-positions (re "%\\w+") fmt-str offset) 43 | [#f 44 | (let ([acc (if (< offset (string-length fmt-str)) 45 | (cons (substring fmt-str offset (string-length fmt-str)) 46 | acc) 47 | acc)]) 48 | (reverse acc))] 49 | [((,start . ,end)) 50 | (let ([acc (if (= offset start) 51 | acc 52 | (cons (substring fmt-str offset start) acc))]) 53 | (lp end (cons `(lookup ,(substring fmt-str (+ start 1) end)) acc)))]))) 54 | 55 | (define (apply-format fmt-expr ht) 56 | (for-each 57 | (lambda (e) 58 | (match e 59 | [(lookup ,key) (display (hashtable-ref ht (string->symbol key) key))] 60 | [,_ (display e)])) 61 | fmt-expr)) 62 | 63 | (define (report x type fmt . args) 64 | (apply-format (report-format) 65 | (match x 66 | [,line (guard (fixnum? line)) 67 | (json:make-object 68 | [file (current-filename)] 69 | [type type] 70 | [line line] 71 | [column ""] 72 | [bfp ""] 73 | [efp ""] 74 | [msg (apply format fmt args)])] 75 | [#(range ,start-line ,start-column ,end-line ,end-column) 76 | (guard (and (fixnum? start-line) (fixnum? start-column) 77 | (fixnum? end-line) (fixnum? end-column))) 78 | (json:make-object 79 | [file (current-filename)] 80 | [type type] 81 | [line start-line] 82 | [column start-column] 83 | [bfp ""] 84 | [efp ""] 85 | [msg (apply format fmt args)])] 86 | [#(near ,code ,line ,column) 87 | (json:make-object 88 | [file (current-filename)] 89 | [type type] 90 | [line (or line 1)] 91 | [column (or column 1)] 92 | [bfp ""] 93 | [efp ""] 94 | [msg (apply format fmt args)])] 95 | [`(annotation [source ,src]) 96 | (let ([bfp (source-object-bfp src)]) 97 | (let-values ([(line char) (fp->line/char (current-source-table) bfp)]) 98 | (json:make-object 99 | [file (current-filename)] 100 | [type type] 101 | [line line] 102 | [column char] 103 | [bfp bfp] 104 | [efp (source-object-efp src)] 105 | [msg (apply format fmt args)])))])) 106 | (newline)) 107 | 108 | (define (flycheck:process-file filename) 109 | (parameterize ([current-filename filename]) 110 | (define loaded #f) 111 | (define return-value 0) 112 | (define (snoop x type fmt . args) 113 | (set! return-value 114 | (max return-value 115 | (match type 116 | [error 2] 117 | [warning 1] 118 | [info 0] 119 | [hint 0]))) 120 | (apply report x type fmt args)) 121 | (match (try (let ([code (utf8->string (read-file filename))]) 122 | (set! loaded code) 123 | (cons code (read-code code)))) 124 | [`(catch ,reason) 125 | (let-values ([(line msg) (reason->line/msg reason loaded)]) 126 | (snoop line 'error msg))] 127 | [(,code . ,annotated-code) 128 | (parameterize ([current-source-table (make-code-lookup-table code)]) 129 | (check-import/export annotated-code snoop) 130 | (check-line-whitespace code #f snoop) 131 | (run-optional-checkers filename #t annotated-code code snoop))]) 132 | return-value)) 133 | ) 134 | -------------------------------------------------------------------------------- /indentation.md: -------------------------------------------------------------------------------- 1 | # Indentation 2 | 3 | With inspiration from 4 | [scmindent](https://github.com/ds26gte/scmindent), this code also 5 | tries to provide a style similar to Emacs while making it 6 | straightforward to add new forms. This code does not currently 7 | provide "options" as we'd like to apply the same rules to all 8 | code. This may change. 9 | 10 | This indenter uses regular expressions to define delimiters in the 11 | file. This allows it to track both code and comments. Generally, it 12 | follows this workflow: 13 | 14 | * tokenize the input 15 | 16 | * mark tokens with properties like comments, strings, and numbers 17 | 18 | * assemble some tokens like named characters and strings 19 | 20 | * indent code 21 | 22 | * indent comments 23 | 24 | ## Not Like Emacs 25 | 26 | Default Emacs configurations use a `fill-column` of 70. Doom Emacs 27 | defaults this to 80 without being explicitly set in the user's 28 | configuration. This code uses 70. 29 | 30 | The following examples attempt to express the differences between the 31 | stock Emacs 27.2 configuration and this indentation code. 32 | 33 | ### Block comments `#| ... |#` 34 | 35 | The indenter leaves block comments alone. This makes them more 36 | convenient for embedding ASCII art and other insignificant trifles of 37 | little importance. 38 | 39 | ### Datum comments `#;` 40 | 41 | The indenter applies its normal code indentation strategy for datum 42 | comments `#;`. 43 | 44 | ### Head subforms 45 | 46 | In Emacs: 47 | ``` scheme 48 | (f e1 49 | e2 50 | e3) 51 | 52 | (foo e1 53 | e2 54 | e3) 55 | ``` 56 | 57 | The indenter opts for two spaces. For the `f` case, this seems less 58 | pleasing, but has the advantage that the subsequent forms will remain 59 | at the same level if `f` is renamed. 60 | ``` scheme 61 | (f e1 62 | e2 63 | e3) 64 | 65 | (foo e1 66 | e2 67 | e3) 68 | ``` 69 | 70 | In Emacs most mathematical operators and single-character identifiers 71 | work as expected. To achieve similar results, the indenter overrides 72 | its default behavior for `+`, `-`, `*`, `/`, `!`, `@`, `$`, `%`, `^`, 73 | `&`, `:`, `?`, `~`, and `_`. Both indent like this: 74 | ``` scheme 75 | (+ e1 76 | e2 77 | e3) 78 | 79 | (@ e1 80 | e2 81 | e3) 82 | ``` 83 | 84 | ### Certain bytevectors 85 | 86 | In Emacs: 87 | ``` scheme 88 | #vu8(#x01 #x02 #x03 89 | #x04 #x05 #x06) 90 | ``` 91 | 92 | The indenter: 93 | ``` scheme 94 | #vu8(#x01 #x02 #x03 95 | #x04 #x05 #x06) 96 | ``` 97 | 98 | ### Certain `cond` cases 99 | 100 | In Emacs: 101 | ``` scheme 102 | (cond 103 | [(and (> (- end start) 0) 104 | (as-token text start end #t)) => 105 | (lambda (t) (proc acc t start end))] 106 | [else acc]) 107 | ``` 108 | 109 | The indenter: 110 | ``` scheme 111 | (cond 112 | [(and (> (- end start) 0) 113 | (as-token text start end #t)) => 114 | (lambda (t) (proc acc t start end))] 115 | [else acc]) 116 | ``` 117 | 118 | ### Certain `match` cases 119 | 120 | In Emacs: 121 | ``` scheme 122 | (match x 123 | [,x 124 | 12] 125 | [#vu8(1 2 3) 126 | 13]) 127 | ``` 128 | 129 | The indenter: 130 | ``` scheme 131 | (match x 132 | [,x 133 | 12] 134 | [#vu8(1 2 3) 135 | 13]) 136 | ``` 137 | 138 | ### Lines that end in dot 139 | 140 | In Emacs: 141 | ``` scheme 142 | (match x 143 | [(,abc . 144 | ,def) 145 | 12]) 146 | ``` 147 | 148 | The indenter: 149 | ``` scheme 150 | (match x 151 | [(,abc . 152 | ,def) 153 | 12]) 154 | ``` 155 | 156 | ### Named Let 157 | 158 | Emacs handles `let` differently than other forms. Emacs may win this 159 | battle. 160 | 161 | In Emacs: 162 | ``` scheme 163 | (let lp 164 | ([x 12] 165 | [y 13]) 166 | body 167 | ...) 168 | ``` 169 | 170 | The indenter: 171 | ``` scheme 172 | (let lp 173 | ([x 12] 174 | [y 13]) 175 | body 176 | ...) 177 | ``` 178 | 179 | ### Unbalanced parenthesis 180 | 181 | Emacs fails to indent this expression. 182 | 183 | The indenter: 184 | ``` scheme 185 | )))))(let ([x 12] 186 | [y 13]) 187 | body 188 | ...) 189 | ``` 190 | -------------------------------------------------------------------------------- /json.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (library (json) 25 | (export 26 | json:get 27 | json:merge 28 | json:write-flat 29 | ) 30 | (import 31 | (chezscheme) 32 | (swish imports) 33 | ) 34 | 35 | (define json:get 36 | (case-lambda 37 | [(ht path default) 38 | (json:ref ht path default)] 39 | [(ht path) 40 | (let ([val (json:ref ht path #!bwp)]) 41 | (when (eq? val #!bwp) 42 | (throw `#(json-path-not-found ,ht ,path))) 43 | val)])) 44 | 45 | (define (json:merge old new) 46 | (let ([r (hashtable-copy old #t)]) 47 | (let-values ([(keys vals) (hashtable-entries new)]) 48 | (vector-for-each 49 | (lambda (k v) 50 | (json:set! r k 51 | (if (not (json:object? v)) 52 | v 53 | (let ([old (json:ref old k #f)]) 54 | (if (json:object? old) 55 | (json:merge old v) 56 | (hashtable-copy v #t)))))) 57 | keys vals)) 58 | r)) 59 | 60 | (define (json:write-flat op x) 61 | (define (symbolstring x) (symbol->string y))) 63 | (let lp ([x x] [path '()]) 64 | (cond 65 | [(json:object? x) 66 | (vector-for-each 67 | (lambda (k) 68 | (lp (hashtable-ref x k #f) (cons k path))) 69 | (vector-sort symbol " (reverse path)) 75 | (json:write op x #f) 76 | (newline op)]))) 77 | ) 78 | -------------------------------------------------------------------------------- /keywords.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (keywords) 24 | (export 25 | get-keywords 26 | ) 27 | (import 28 | (chezscheme) 29 | (json) 30 | (swish imports) 31 | ) 32 | 33 | (define (read-keyword ip) 34 | (let ([c (peek-char ip)]) 35 | (cond 36 | [(eof-object? c) c] 37 | [(char=? c #\() 38 | (match (read ip) 39 | [(,keyword . ,lib) 40 | (json:make-object 41 | [keyword (format "~a" keyword)] 42 | [meta (json:make-object [library (format "~s" lib)])])])] 43 | [(char=? c #\{) 44 | (let ([obj (json:read ip)]) 45 | (unless (json:ref obj 'keyword #f) 46 | (throw `#(invalid-input ,obj))) 47 | (unless (json:ref obj 'meta #f) 48 | (json:set! obj 'meta (json:make-object))) 49 | obj)] 50 | [else 51 | (let ([keyword (trim-whitespace (get-line ip))]) 52 | (if (string=? keyword "") 53 | (read-keyword ip) 54 | (json:make-object 55 | [keyword keyword] 56 | [meta (json:make-object)])))]))) 57 | 58 | (define (read-keywords ip ht) 59 | (let lp () 60 | (let ([x (read-keyword ip)]) 61 | (unless (eof-object? x) 62 | (let ([kw (json:ref x 'keyword #f)]) 63 | (unless kw 64 | (throw `#(invalid-input ,x))) 65 | (hashtable-update! ht kw 66 | (lambda (old) 67 | (if old 68 | (json:merge old x) 69 | x)) 70 | #f) 71 | (lp)))))) 72 | 73 | (define (static-keywords ht) 74 | (define static (path-combine (base-dir) "static-keywords")) 75 | (when (regular-file? static) 76 | (let ([ip (open-file-to-read static)]) 77 | (on-exit (close-port ip) 78 | (read-keywords ip ht))))) 79 | 80 | (define (generate-keywords-expr libs) 81 | `(for-each 82 | (lambda (lib) 83 | (for-each 84 | (lambda (export) 85 | (printf "(~s . ~s)\n" export lib)) 86 | (library-exports lib))) 87 | ,libs)) 88 | 89 | (define (generate-keywords ht report-error) 90 | (let f ([exes '((("swish" "-q") (scheme) ,@(library-requirements '(swish imports))) 91 | (("scheme" "-q") (scheme)) 92 | (("petite" "-q") (scheme)))]) 93 | (match exes 94 | [() 95 | (read-keywords 96 | (open-input-string 97 | (with-output-to-string 98 | (lambda () 99 | (eval (generate-keywords-expr '(quote ((scheme)))))))) 100 | ht)] 101 | [(((,exe . ,args) . ,libs) . ,rest) 102 | (call-with-values 103 | (lambda () (try (spawn-os-process exe args self))) 104 | (case-lambda 105 | [(fault) 106 | (report-error fault) 107 | (f rest)] 108 | [(to-stdin from-stdout from-stderr os-pid) 109 | (let ([to-stdin (binary->utf8 to-stdin)] 110 | [from-stdout (binary->utf8 from-stdout)] 111 | [from-stderr (binary->utf8 from-stderr)]) 112 | (fprintf to-stdin "~s\n" (generate-keywords-expr `(,'quasiquote ,libs))) 113 | (on-exit (begin (close-input-port from-stdout) 114 | (close-input-port from-stderr)) 115 | (close-output-port to-stdin) 116 | (read-keywords from-stdout ht) 117 | (receive 118 | (after 10000 119 | (osi_kill* os-pid 15) 120 | (throw 'os-process-timeout)) 121 | [#(process-terminated ,@os-pid ,exit-status ,_) 122 | (unless (= exit-status 0) 123 | (errorf 'generate-keywords 124 | "~a subprocess exited with non-zero status: ~a" exe exit-status))])))]))]))) 125 | 126 | (define (get-keywords report-error) 127 | (match (try 128 | (let ([ht (make-hashtable string-hash string=?)]) 129 | (generate-keywords ht report-error) 130 | (static-keywords ht) 131 | (vector->list (hashtable-values ht)))) 132 | [`(catch ,_ ,err) 133 | (report-error err) 134 | '()] 135 | [,keywords keywords])) 136 | ) 137 | -------------------------------------------------------------------------------- /lsp-swish.el: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (require 'lsp-mode) 24 | 25 | (defun swish-indent-sexp () 26 | "Indent each line of the sexp starting just after point." 27 | (interactive) 28 | (save-excursion 29 | (let ((start (point))) 30 | (forward-sexp 1) 31 | (lsp-format-region start (point))))) 32 | 33 | (defun swish-indent-line () 34 | "Indent current line as Scheme code." 35 | (interactive) 36 | (save-excursion 37 | (beginning-of-line) 38 | (let ((start (point))) 39 | (end-of-line) 40 | (lsp-format-region start (point)))) 41 | (skip-chars-forward " \t")) 42 | 43 | (add-to-list 'lsp-language-id-configuration '(scheme-mode . "scheme")) 44 | 45 | (lsp-register-client 46 | (make-lsp-client 47 | :new-connection (lsp-stdio-connection 48 | '("swish-lint" "--lsp")) 49 | :major-modes '(scheme-mode) 50 | :server-id 'swish-ls 51 | )) 52 | 53 | (add-hook 'scheme-mode-hook #'lsp) 54 | 55 | (provide 'lsp-swish) 56 | -------------------------------------------------------------------------------- /lsp.ms: -------------------------------------------------------------------------------- 1 | (import 2 | (checkers) 3 | (config-params) 4 | (json) 5 | (lsp) 6 | (software-info) 7 | (testing common) 8 | (testing pipe) 9 | (testing rpc) 10 | (tower) 11 | ) 12 | 13 | (software-info:install) 14 | 15 | (define-syntax code 16 | (syntax-rules () 17 | [(_ str ...) 18 | (ct:join #\newline str ...)])) 19 | 20 | (define (capture-progress) 21 | (define-tuple token kind message percentage) 22 | (rpc-client:set-event-handler 'rpc 'progress 23 | (lambda (event) 24 | (and (equal? (json:ref event 'method #f) "$/progress") 25 | (let* ([params (json:get event 'params)] 26 | [value (json:get params 'value)]) 27 | ( make 28 | [token (json:get params 'token)] 29 | [kind (json:get value 'kind)] 30 | [message (json:ref value 'message #f)] 31 | [percentage (json:ref value 'percentage #f)])))) 32 | self) 33 | (lambda (token) 34 | (receive 35 | [`( ,@token [kind "begin"] ,percentage) 36 | (let lp ([prior percentage]) 37 | (receive 38 | [`( ,@token [kind "end"]) 'ok] 39 | [`( ,@token [kind "report"] ,percentage) 40 | (assert (>= percentage prior)) 41 | (lp percentage)]))]))) 42 | 43 | (define (capture-test-sync) 44 | (let ([me self]) 45 | (spawn 46 | (lambda () 47 | (event-mgr:add-handler 48 | (lambda (event) 49 | (match event 50 | [(test-sync . ,_) (send me event)] 51 | [,_ #f]))) 52 | (receive)))) 53 | (lambda (uri) 54 | (receive [(test-sync . ,@uri) 'ok]))) 55 | 56 | (define (capture-diagnostics) 57 | (define-tuple uri diagnostics) 58 | (rpc-client:set-event-handler 'rpc 'diagnostics 59 | (lambda (event) 60 | (and (equal? (json:ref event 'method #f) "textDocument/publishDiagnostics") 61 | (let ([params (json:get event 'params)]) 62 | ( make 63 | [uri (json:get params 'uri)] 64 | [diagnostics (json:get params 'diagnostics)])))) 65 | self) 66 | (lambda (uri timeout) 67 | (receive (after timeout #f) 68 | [`( ,@uri ,diagnostics) diagnostics]))) 69 | 70 | (define (start-lsp-server path) 71 | (define-values (ip1 op1) (make-pipe "pipe1")) 72 | (define-values (ip2 op2) (make-pipe "pipe2")) 73 | (define-values (tip top) (make-pipe "trace pipe")) 74 | 75 | (log-file ":memory:") 76 | (match-let* 77 | ([,ip1 (binary->utf8 ip1)] 78 | [,op1 (binary->utf8 op1)] 79 | [,ip2 (binary->utf8 ip2)] 80 | [,op2 (binary->utf8 op2)] 81 | [#(ok ,_) (supervisor:start&link 'main-sup 'one-for-all 0 1 82 | (append 83 | (make-swish-sup-spec (list swish-event-logger)) 84 | (tower:sup-spec 0) 85 | (lsp:sup-spec #f ip1 op2 #t)))] 86 | [#(ok ,rpc) (rpc-client:start&link 'rpc 87 | (lambda (msg) 88 | ;;(json:write (trace-output-port) msg 0) 89 | (lsp:write-msg op1 msg) 90 | (flush-output-port op1)))] 91 | [,rlp (spawn&link 92 | (lambda () 93 | (lsp:read-loop ip2 94 | (lambda (msg) 95 | ;;(json:write (trace-output-port) msg 0) 96 | (rpc-client:message rpc msg)))))]) 97 | (define wait-for-progress (capture-progress)) 98 | (rpc-client:call rpc 99 | (json:make-object 100 | [jsonrpc "2.0"] 101 | [method "initialize"] 102 | [params 103 | (json:make-object 104 | [rootUri 105 | (cond 106 | [(and path (format "file://~a" path))] 107 | [else #\nul])] 108 | [capabilities (json:make-object)])])) 109 | (rpc-client:notify rpc 110 | (json:make-object 111 | [jsonrpc "2.0"] 112 | [method "initialized"] 113 | [params (json:make-object)])) 114 | (cond 115 | [path 116 | (wait-for-progress "enumerate-directories")] 117 | [else 118 | ;; give server enough time to process the messages, possibly 119 | ;; producing startup messages. 120 | (receive (after 100 'ok))]) 121 | rpc)) 122 | 123 | (define (stop-lsp-server rpc) 124 | (rpc-client:call rpc 125 | (json:make-object 126 | [jsonrpc "2.0"] 127 | [method "shutdown"] 128 | [params (json:make-object)])) 129 | 130 | (when (whereis 'log-db) 131 | (transaction 'log-db 'ok)) 132 | (cond 133 | [(whereis 'main-sup) => 134 | (lambda (pid) 135 | (define os (open-output-string)) 136 | (unlink pid) 137 | (monitor pid) 138 | (parameterize ([console-error-port os]) 139 | (kill pid 'shutdown) 140 | (receive (after 15000 141 | (display (get-output-string os)) 142 | (throw 'timeout-in-stop)) 143 | [`(DOWN ,_ ,@pid ,_) 'ok])))] 144 | [else 'ok])) 145 | 146 | (define (did-open uri text) 147 | (rpc-client:notify 'rpc 148 | (json:make-object 149 | [jsonrpc "2.0"] 150 | [method "textDocument/didOpen"] 151 | [params 152 | (json:make-object 153 | [textDocument 154 | (json:make-object 155 | [uri uri] 156 | [text text])])]))) 157 | 158 | (define (did-change uri text) 159 | (rpc-client:notify 'rpc 160 | (json:make-object 161 | [jsonrpc "2.0"] 162 | [method "textDocument/didChange"] 163 | [params 164 | (json:make-object 165 | [textDocument 166 | (json:make-object 167 | [uri uri])] 168 | [contentChanges 169 | (list 170 | (json:make-object 171 | [text text]))])]))) 172 | 173 | (define (did-save uri text) 174 | (rpc-client:notify 'rpc 175 | (json:make-object 176 | [jsonrpc "2.0"] 177 | [method "textDocument/didSave"] 178 | [params 179 | (json:make-object 180 | [textDocument 181 | (json:make-object 182 | [uri uri])] 183 | [text text])]))) 184 | 185 | (define (did-close uri) 186 | (rpc-client:notify 'rpc 187 | (json:make-object 188 | [jsonrpc "2.0"] 189 | [method "textDocument/didClose"] 190 | [params 191 | (json:make-object 192 | [textDocument 193 | (json:make-object 194 | [uri uri])])]))) 195 | 196 | (define (format-document uri) 197 | (rpc-client:call 'rpc 198 | (json:make-object 199 | [jsonrpc "2.0"] 200 | [method "textDocument/formatting"] 201 | [params 202 | (json:make-object 203 | [textDocument 204 | (json:make-object 205 | [uri uri])] 206 | [options (json:make-object)])]))) 207 | 208 | (define (format-range uri start-line0 start-char0 end-line0 end-char0) 209 | (rpc-client:call 'rpc 210 | (json:make-object 211 | [jsonrpc "2.0"] 212 | [method "textDocument/rangeFormatting"] 213 | [params 214 | (json:make-object 215 | [textDocument 216 | (json:make-object 217 | [uri uri])] 218 | [options (json:make-object)] 219 | [range 220 | (json:make-object 221 | [start 222 | (json:make-object 223 | [line start-line0] 224 | [character start-char0])] 225 | [end 226 | (json:make-object 227 | [line end-line0] 228 | [character end-char0])])])]))) 229 | 230 | (define (get-completions uri line0 char0) 231 | (rpc-client:call 'rpc 232 | (json:make-object 233 | [jsonrpc "2.0"] 234 | [method "textDocument/completion"] 235 | [params 236 | (json:make-object 237 | [textDocument 238 | (json:make-object 239 | [uri uri])] 240 | [position 241 | (json:make-object 242 | [line line0] 243 | [character char0])])]))) 244 | 245 | (define (get-definitions uri line0 char0) 246 | (rpc-client:call 'rpc 247 | (json:make-object 248 | [jsonrpc "2.0"] 249 | [method "textDocument/definition"] 250 | [params 251 | (json:make-object 252 | [textDocument 253 | (json:make-object 254 | [uri uri])] 255 | [position 256 | (json:make-object 257 | [line line0] 258 | [character char0])])]))) 259 | 260 | (define (get-highlights uri line0 char0) 261 | (rpc-client:call 'rpc 262 | (json:make-object 263 | [jsonrpc "2.0"] 264 | [method "textDocument/documentHighlight"] 265 | [params 266 | (json:make-object 267 | [textDocument 268 | (json:make-object 269 | [uri uri])] 270 | [position 271 | (json:make-object 272 | [line line0] 273 | [character char0])])]))) 274 | 275 | (define (get-references uri line0 char0) 276 | (rpc-client:call 'rpc 277 | (json:make-object 278 | [jsonrpc "2.0"] 279 | [method "textDocument/references"] 280 | [params 281 | (json:make-object 282 | [textDocument 283 | (json:make-object 284 | [uri uri])] 285 | [position 286 | (json:make-object 287 | [line line0] 288 | [character char0])])]))) 289 | 290 | (isolate-mat no-root-folder () 291 | (let ([rpc (start-lsp-server #f)]) 292 | (on-exit (stop-lsp-server rpc) 293 | 'ok))) 294 | 295 | (isolate-mat smoke () 296 | (let ([rpc (start-lsp-server (get-real-path "."))]) 297 | (on-exit (stop-lsp-server rpc) 298 | 'ok))) 299 | 300 | (isolate-mat completions () 301 | (define (extract-labels ls) 302 | (map (lambda (obj) (json:ref obj 'label #f)) ls)) 303 | 304 | (define (all uri str expect) 305 | (did-change uri str) 306 | (let ([max (string-length str)]) 307 | (let lp ([n 0] [expect expect]) 308 | (cond 309 | [(> n max) (assert (null? expect))] 310 | [else 311 | (let ([actual (extract-labels (get-completions uri 0 n))]) 312 | (match expect 313 | [() (throw `#(not-enough-expected actual: ,actual))] 314 | [(,exp . ,rest) 315 | (unless (equal? actual exp) 316 | (printf "~a: ~a\n" actual exp) 317 | (throw `#(failed ,actual ,exp))) 318 | (lp (+ n 1) rest)]))])))) 319 | 320 | ;; TODO: This needs to be more robust in the presence of stray files 321 | ;; in the testing directory. Possibly need to create a separate 322 | ;; directory and write code into it instead of using swish-lint's 323 | ;; directory. 324 | (let ([rpc (start-lsp-server (get-real-path "."))]) 325 | (on-exit (stop-lsp-server rpc) 326 | (assert (null? (get-completions "file:///tmp/does-not-exist.ss" 0 0))) 327 | (let ([uri "file:///tmp/foo.ss"]) 328 | (did-open uri "") 329 | (all uri "1" '(() ())) 330 | (all uri "()" '(() () ())) 331 | (all uri "(1)" '(() () () ())) 332 | (all uri "(z)" '(() () ("zero?") ())) 333 | (all uri "(ze)" '(() () ("zero?") ("zero?") ())) 334 | (all uri "(zed)" '(() () () () () ())) 335 | (all uri "(#)" '(() () () ())) 336 | (all uri "(#%)" '(() () () () ())) 337 | (all uri "(#%z)" '(() () ("zero?") ("zero?") ("zero?") ())) 338 | (all uri "(#%ze)" '(() () ("zero?") ("zero?") ("zero?") ("zero?") ())) 339 | (all uri "(#%zed)" '(() () () () () () () ())) 340 | (all uri "(#2%z)" '(() () ("zero?") ("zero?") ("zero?") ("zero?") ())) 341 | (all uri "(#2%ze)" '(() () ("zero?") ("zero?") ("zero?") ("zero?") ("zero?") ())) 342 | (all uri "(#2%zed)" '(() () () () () () () () ())) 343 | 344 | ;; Completions should not include the identifier under the 345 | ;; cursor when it's the only reference. 346 | ;; 347 | ;; Completions don't include the current non-keyword 348 | ;; identifiers until the file is saved. 349 | (match-let* 350 | ([,_ (did-save uri "(let ([zyx")] 351 | [() (extract-labels (get-completions uri 0 10))] 352 | [,_ (did-save uri "(let ([zyx 12]) (+ z 12))")] 353 | [("zyx" "zero?") (extract-labels (get-completions uri 0 20))] 354 | [,_ (did-save uri "(let ([zyx 12]) (+ zyx 12))")] 355 | [("zyx") (extract-labels (get-completions uri 0 22))]) 356 | 'ok) 357 | ;; Check that identifiers containing '%' and '_' do not 358 | ;; confuse LIKE query. 359 | (match-let* 360 | ([,_ (did-save uri "(let ([%abc")] 361 | [() (extract-labels (get-completions uri 0 11))] 362 | [,_ (did-save uri "(let ([%abc 12]) (+ %a 12))")] 363 | [("%abc") (extract-labels (get-completions uri 0 22))]) 364 | 'ok) 365 | (match-let* 366 | ([,_ (did-save uri "(let ([_a%bc")] 367 | [() (extract-labels (get-completions uri 0 11))] 368 | [,_ (did-save uri "(let ([_a%bc 12]) (+ _a 12))")] 369 | [("_a%bc") (extract-labels (get-completions uri 0 24))]) 370 | 'ok) 371 | (did-close uri) 372 | 'ok)))) 373 | 374 | (define (extract-range r) 375 | (list 376 | 'from 377 | (json:get r '(start line)) 378 | (json:get r '(start character)) 379 | 'to 380 | (json:get r '(end line)) 381 | (json:get r '(end character)))) 382 | 383 | (isolate-mat defns/refs () 384 | (define (extract-ranges ls) 385 | (map 386 | (lambda (obj) 387 | (list* (json:ref obj 'uri #f) 388 | (extract-range (json:get obj 'range)))) 389 | ls)) 390 | (define (get-defns uri line0 char0) 391 | (extract-ranges (get-definitions uri line0 char0))) 392 | (define (get-refs uri line0 char0) 393 | (extract-ranges (get-references uri line0 char0))) 394 | (define (get-local-refs uri line0 char0) 395 | ;; For sanity, slam the uri into the extracted ranges 396 | (map 397 | (lambda (ls) 398 | (assert (eq? (car ls) #f)) 399 | (cons uri (cdr ls))) 400 | (extract-ranges (get-highlights uri line0 char0)))) 401 | 402 | (define (check-range range f) 403 | ;; All calls f within the range should be the same. Calls outside 404 | ;; the range should be different. 405 | (match range 406 | [(,uri from ,sl ,sc to ,el ,ec) 407 | (let ([r (f uri sl sc)]) 408 | (when (not (null? r)) 409 | (assert (not (equal? r (f uri sl (- sc 1)))))) 410 | (do ([c (+ sc 1) (+ c 1)]) ((= c ec)) 411 | (assert (equal? r (f uri sl c)))) 412 | (when (not (null? r)) 413 | (assert (not (equal? r (f uri sl (+ ec 1)))))) 414 | r)])) 415 | 416 | (let ([rpc (start-lsp-server (get-real-path "."))]) 417 | (on-exit (stop-lsp-server rpc) 418 | (define wait-for-test-sync (capture-test-sync)) 419 | 420 | (assert (null? (get-defns "file:///tmp/does-not-exist.ss" 0 0))) 421 | (assert (null? (get-local-refs "file:///tmp/does-not-exist.ss" 0 0))) 422 | (assert (null? (get-refs "file:///tmp/does-not-exist.ss" 0 0))) 423 | (let* ([uri1 "file:///tmp/file1.ss"] 424 | [uri2 "file:///tmp/file2.ss"] 425 | [uris (list uri1 uri2)]) 426 | (for-each 427 | (lambda (uri) (did-open uri "")) 428 | uris) 429 | (for-each wait-for-test-sync uris) 430 | (did-change uri1 431 | (code 432 | "(define foo 12)" 433 | "(define bar 13)" 434 | "(define baz (+ foo bar))" 435 | "(define #{g0 irkaa9foht6pk4yacg2xmr1pt-0} 14)" 436 | "(define |nonstandard symbol| 15)" 437 | )) 438 | (did-change uri2 439 | (code 440 | "(let ([sum (+ foo bar baz)])" 441 | " sum)" 442 | "(let ([prod (* #{g0 irkaa9foht6pk4yacg2xmr1pt-0} |nonstandard symbol|)])" 443 | " prod)" 444 | )) 445 | (for-each wait-for-test-sync uris) 446 | 447 | (match-let* 448 | ([,foo-defn `(,uri1 from 0 8 to 0 11)] 449 | [,bar-defn `(,uri1 from 1 8 to 1 11)] 450 | [,baz-defn `(,uri1 from 2 8 to 2 11)] 451 | [,foo-ref1 `(,uri1 from 2 15 to 2 18)] 452 | [,bar-ref1 `(,uri1 from 2 19 to 2 22)] 453 | [,gen-defn `(,uri1 from 3 8 to 3 41)] 454 | [,nss-defn `(,uri1 from 4 8 to 4 28)] 455 | 456 | [,sum-ref1 `(,uri2 from 0 7 to 0 10)] 457 | [,foo-ref2 `(,uri2 from 0 14 to 0 17)] 458 | [,bar-ref2 `(,uri2 from 0 18 to 0 21)] 459 | [,baz-ref2 `(,uri2 from 0 22 to 0 25)] 460 | [,sum-ref2 `(,uri2 from 1 2 to 1 5)] 461 | 462 | [,prod-ref1 `(,uri2 from 2 7 to 2 11)] 463 | [,gen-ref1 `(,uri2 from 2 15 to 2 48)] 464 | [,nss-ref1 `(,uri2 from 2 49 to 2 69)] 465 | [,prod-ref2 `(,uri2 from 3 2 to 3 6)] 466 | 467 | ;; foo 468 | [(,@foo-defn) (check-range foo-defn get-defns)] 469 | [(,@foo-defn ,@foo-ref1) (check-range foo-defn get-local-refs)] 470 | [(,@foo-ref2) (check-range foo-ref2 get-local-refs)] 471 | [(,@foo-defn ,@foo-ref1 ,@foo-ref2) (check-range foo-defn get-refs)] 472 | 473 | ;; 12 474 | [() (get-defns uri1 0 12)] 475 | 476 | ;; bar 477 | [(,@bar-defn) (check-range bar-defn get-defns)] 478 | [(,@bar-defn ,@bar-ref1) (check-range bar-defn get-local-refs)] 479 | [(,@bar-ref2) (check-range bar-ref2 get-local-refs)] 480 | [(,@bar-defn ,@bar-ref1 ,@bar-ref2) (check-range bar-defn get-refs)] 481 | 482 | ;; 13 483 | [() (get-defns uri1 1 12)] 484 | 485 | ;; baz 486 | [(,@baz-defn) (check-range baz-defn get-defns)] 487 | [(,@baz-defn) (check-range baz-defn get-local-refs)] 488 | [(,@baz-ref2) (check-range baz-ref2 get-local-refs)] 489 | [(,@baz-defn ,@baz-ref2) (check-range baz-defn get-refs)] 490 | 491 | [(,@foo-defn) (check-range foo-ref1 get-defns)] 492 | [(,@bar-defn) (check-range bar-ref1 get-defns)] 493 | 494 | ;; gensym 495 | [(,@gen-defn) (check-range gen-defn get-defns)] 496 | [(,@gen-defn) (check-range gen-defn get-local-refs)] 497 | [(,@gen-ref1) (check-range gen-ref1 get-local-refs)] 498 | [(,@gen-defn ,@gen-ref1) (check-range gen-defn get-refs)] 499 | 500 | ;; nonstandard symbol 501 | [(,@nss-defn) (check-range nss-defn get-defns)] 502 | [(,@nss-defn) (check-range nss-defn get-local-refs)] 503 | [(,@nss-ref1) (check-range nss-ref1 get-local-refs)] 504 | [(,@nss-defn ,@nss-ref1) (check-range nss-defn get-refs)] 505 | 506 | [() (check-range sum-ref1 get-defns)] ; currently let bindings are not defns 507 | [() (check-range sum-ref2 get-defns)] ; currently let bindings are not defns 508 | [(,@foo-defn) (check-range foo-ref2 get-defns)] 509 | [(,@bar-defn) (check-range bar-ref2 get-defns)] 510 | [(,@baz-defn) (check-range baz-ref2 get-defns)] 511 | [() (check-range prod-ref1 get-defns)] ; currently let bindings are not defns 512 | [() (check-range prod-ref2 get-defns)] ; currently let bindings are not defns 513 | [(,@gen-defn) (check-range gen-ref1 get-defns)] 514 | [(,@nss-defn) (check-range nss-ref1 get-defns)]) 515 | 'ok) 516 | 517 | (did-change uri1 518 | (code 519 | "(define-syntax (define-thing x)" 520 | " (syntax-case x ()" 521 | " [(_) #'(begin 'thing)]))" 522 | "" 523 | "x" 524 | )) 525 | (wait-for-test-sync uri1) 526 | (match-let* 527 | ([,define-thing-defn `(,uri1 from 0 16 to 0 28)] 528 | [,x-defn `(,uri1 from 0 29 to 0 30)] 529 | [(,@define-thing-defn) (check-range define-thing-defn get-defns)] 530 | [(,@x-defn) (check-range x-defn get-defns)] 531 | ;; The current code incorrectly determines (define-thing x) 532 | ;; is the definition of `x`. A future implementation may 533 | ;; treat `x` as a local definition, and the following test 534 | ;; result would change. 535 | [(,@x-defn) (get-defns uri1 4 0)]) 536 | 'ok) 537 | 538 | ;; If we ever decide to treat marks as definitions, the test 539 | ;; results here would change. 540 | (did-change uri1 541 | (code "(list #0=0 #1=1 #1# #0#)")) 542 | (wait-for-test-sync uri1) 543 | (match-let* 544 | ([() (get-defns uri1 0 6)] 545 | [() (get-defns uri1 0 11)] 546 | [() (get-defns uri1 0 16)] 547 | [() (get-defns uri1 0 20)]) 548 | 'ok) 549 | 550 | (for-each did-close uris) 551 | 'ok)))) 552 | 553 | (isolate-mat diagnostics () 554 | (define (extract-diagnostics ls) 555 | (map 556 | (lambda (obj) 557 | (list* (json:get obj 'message) 558 | (json:get obj 'severity) 559 | (extract-range (json:get obj 'range)))) 560 | ls)) 561 | (let ([rpc (start-lsp-server (get-real-path "."))]) 562 | (on-exit (stop-lsp-server rpc) 563 | (define wait-for-test-sync (capture-test-sync)) 564 | (define wait-for-diagnostics (capture-diagnostics)) 565 | (define (flush-diagnostics uri) 566 | (when (wait-for-diagnostics uri 100) 567 | (flush-diagnostics uri))) 568 | (let ([uri "file:///tmp/foo.ss"]) 569 | (did-open uri "") 570 | (wait-for-test-sync uri) 571 | (flush-diagnostics uri) 572 | 573 | ;; checks report handling of line 574 | (did-change uri "(") 575 | (match (extract-diagnostics (wait-for-diagnostics uri 5000)) 576 | [(("unexpected end-of-file reading list" 1 from 0 0 to 1 0)) 577 | (flush-diagnostics uri)]) 578 | 579 | ;; checks report handling of range 580 | (parameterize ([optional-checkers 581 | (list 582 | (make-regexp-checker 'info "INFO.*") 583 | (make-regexp-checker 'warning "WARNING.*") 584 | (make-regexp-checker 'error "ERROR.*"))]) 585 | (did-change uri 586 | (code 587 | "(let ()" 588 | " body ; INFO: informative" 589 | " body ; WARNING: be careful" 590 | " body ; ERROR: this is broken" 591 | " body)")) 592 | (match (extract-diagnostics (wait-for-diagnostics uri 5000)) 593 | [(("ERROR: this is broken" 1 from 3 11 to 3 32) 594 | ("WARNING: be careful" 2 from 2 11 to 2 30) 595 | ("INFO: informative" 3 from 1 11 to 1 28)) 596 | (flush-diagnostics uri)])) 597 | 598 | ;; checks report handling of annotation 599 | (did-change uri 600 | (code 601 | "(import" 602 | " (omega)" 603 | " (alpha))")) 604 | (match (extract-diagnostics (wait-for-diagnostics uri 5000)) 605 | [(("incorrectly sorted: (alpha)" 3 from 2 2 to 2 9) 606 | ("incorrectly sorted: (omega)" 3 from 1 2 to 1 9) 607 | ("should sort imports" 2 from 0 1 to 0 7)) 608 | (flush-diagnostics uri)]) 609 | 610 | ;; cover cases in ->lsp-range used by external checkers 611 | (with-tmp-dir 612 | (let ([fn (path-combine (tmp-dir) "ranges")] 613 | [msg "Exception in car: 12 is not a pair"]) 614 | (write-script fn 615 | `((json:pretty 616 | (json:make-object ; no range 617 | [message ,msg])) 618 | (json:pretty 619 | (json:make-object ; line only 620 | [line 10] 621 | [message ,msg])) 622 | (json:pretty 623 | (json:make-object ; line/column point to an atomic 624 | [line 1] 625 | [column 3] 626 | [message ,msg])) 627 | (json:pretty ; line/column do not point to an atomic 628 | (json:make-object 629 | [line 1] 630 | [column 10] 631 | [message ,msg])))) 632 | (parameterize ([optional-checkers (list (make-external-checker (list fn)))]) 633 | (did-save uri ; must save to run external checker 634 | (code 635 | "(car 12)")) 636 | (match (extract-diagnostics (wait-for-diagnostics uri 5000)) 637 | [((,@msg 1 from 0 9 to 1 0) 638 | (,@msg 1 from 0 1 to 0 4) 639 | (,@msg 1 from 9 0 to 10 0) 640 | (,@msg 1 from 0 0 to 1 0)) 641 | (flush-diagnostics uri)])) 642 | (remove-file fn))) 643 | 644 | (did-close uri) 645 | 'ok)))) 646 | 647 | (isolate-mat formatting () 648 | (define (extract-edits ls) 649 | (map 650 | (lambda (obj) 651 | (list (json:get obj 'newText) 652 | (extract-range (json:get obj 'range)))) 653 | ls)) 654 | (let ([rpc (start-lsp-server (get-real-path "."))]) 655 | (on-exit (stop-lsp-server rpc) 656 | (define wait-for-test-sync (capture-test-sync)) 657 | 658 | (assert (null? (format-document "file:///tmp/does-not-exist.ss"))) 659 | (assert (null? (format-range "file:///tmp/does-not-exist.ss" 0 0 1 0))) 660 | (let ([uri "file:///tmp/foo.ss"]) 661 | (did-open uri 662 | (code 663 | "(define (add2 x)" 664 | "(let ([y 1]" 665 | "[z 1])" 666 | "(+ x y z)))")) 667 | (wait-for-test-sync uri) 668 | 669 | ;; In this test we ask for reformatting, but we don't actually 670 | ;; apply the edits. The server's state of the code remains 671 | ;; unchanged. 672 | (match-let* 673 | ([,line3 '(" (+ x y z)))" (from 3 0 to 3 15))] 674 | [() (extract-edits (format-range uri 3 0 3 0))] 675 | [(,@line3) (extract-edits (format-range uri 3 0 3 1))] 676 | [(,@line3) (extract-edits (format-range uri 3 0 3 15))] 677 | [(,@line3) (extract-edits (format-range uri 3 0 4 0))] 678 | 679 | [,line2 '(" [z 1])" (from 2 0 to 2 14))] 680 | [() (extract-edits (format-range uri 2 0 2 0))] 681 | [(,@line2) (extract-edits (format-range uri 2 0 2 1))] 682 | [(,@line2) (extract-edits (format-range uri 2 0 2 14))] 683 | [(,@line2) (extract-edits (format-range uri 2 0 3 0))] 684 | 685 | [(,@line2 ,@line3) (extract-edits (format-range uri 2 0 4 0))] 686 | 687 | [,line1 '(" (let ([y 1]" (from 1 0 to 1 13))] 688 | [() (extract-edits (format-range uri 1 0 1 0))] 689 | [(,@line1) (extract-edits (format-range uri 1 0 1 1))] 690 | [(,@line1) (extract-edits (format-range uri 1 0 1 13))] 691 | [(,@line1) (extract-edits (format-range uri 1 0 2 0))] 692 | 693 | [(,@line1 ,@line2) (extract-edits (format-range uri 1 0 3 0))] 694 | [(,@line1 ,@line2 ,@line3) (extract-edits (format-range uri 1 0 4 0))] 695 | 696 | [(,@line1 ,@line2 ,@line3) (extract-edits (format-document uri))]) 697 | 'ok) 698 | 699 | (did-close uri) 700 | 'ok)))) 701 | 702 | (isolate-mat semver () 703 | ;; from https://semver.org/#is-there-a-suggested-regular-expression-regex-to-check-a-semver-string 704 | (define pat (re "^(0|[1-9]\\d*)\\.(0|[1-9]\\d*)\\.(0|[1-9]\\d*)(?:-((?:0|[1-9]\\d*|\\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\\.(?:0|[1-9]\\d*|\\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\\+([0-9a-zA-Z-]+(?:\\.[0-9a-zA-Z-]+)*))?$")) 705 | ;; check that we're building at or after a sensible tag 706 | (assert (pregexp-match pat (software-version 'swish-lint)))) 707 | -------------------------------------------------------------------------------- /lsp.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (library (lsp) 25 | (export 26 | lsp:read-loop 27 | lsp:start-server 28 | lsp:sup-spec 29 | lsp:write-msg 30 | ) 31 | (import 32 | (checkers) 33 | (chezscheme) 34 | (config) 35 | (config-params) 36 | (cursor) 37 | (doc) 38 | (indent) 39 | (json) 40 | (keywords) 41 | (progress) 42 | (read) 43 | (software-info) 44 | (swish imports) 45 | (tower-client) 46 | (trace) 47 | ) 48 | 49 | (define (lsp:read-loop ip proc) 50 | (let lp ([header '()]) 51 | (let ([line (get-line ip)]) 52 | (if (string=? line "") 53 | (lp header) 54 | (match (pregexp-match (re "(\\S+): (\\S+)") line) 55 | [(,_ ,key ,val) (lp (cons (cons key val) header))] 56 | [#f 57 | (proc (json:read ip)) 58 | (lp '())]))))) 59 | 60 | (define (lsp:start-reader ip proc) 61 | `#(ok 62 | ,(spawn&link 63 | (lambda () 64 | (lsp:read-loop ip proc))))) 65 | 66 | (define (lsp:write-msg op msg) 67 | (let* ([bv (json:object->bytevector msg)] 68 | [str (utf8->string bv)]) 69 | (fprintf op "Content-Length: ~a\r\n\r\n" (bytevector-length bv)) 70 | (display-string str op))) 71 | 72 | (define (lsp:start-writer op) 73 | `#(ok 74 | ,(spawn&link 75 | (lambda () 76 | (register 'lsp-writer self) 77 | (let lp ([timeout 'infinity]) 78 | (receive 79 | (after timeout 80 | (flush-output-port op) 81 | (lp 'infinity)) 82 | [#(send-msg ,msg) 83 | (lsp:write-msg op msg) 84 | (lp 1)])))))) 85 | 86 | (define (lsp:send msg) 87 | (unless (json:object? msg) 88 | (bad-arg 'lsp:send msg)) 89 | (cond 90 | [(whereis 'lsp-writer) => 91 | (lambda (pid) 92 | (send pid `#(send-msg ,msg)))])) 93 | 94 | (define (lsp:log type msg) 95 | (unless (string? msg) 96 | (bad-arg 'lsp:log msg)) 97 | (rpc:fire-event "window/logMessage" 98 | (json:make-object 99 | [type 100 | (match type 101 | [error 1] 102 | [warning 2] 103 | [info 3] 104 | [log 4])] 105 | [message msg]))) 106 | 107 | (define (rpc:respond id result) 108 | (let ([res (json:make-object [jsonrpc "2.0"] [id id])]) 109 | (when result 110 | (json:extend-object res [result result])) 111 | (lsp:send res))) 112 | 113 | (define (rpc:request id method params) 114 | (lsp:send 115 | (trace-msg 116 | (json:make-object 117 | [jsonrpc "2.0"] 118 | [id id] 119 | [method method] 120 | [params params])))) 121 | 122 | (define (rpc:fire-event method params) 123 | (lsp:send 124 | (json:make-object 125 | [jsonrpc "2.0"] 126 | [method method] 127 | [params params]))) 128 | 129 | (define (rpc:respond-error id code reason) 130 | (lsp:send 131 | (json:make-object 132 | [jsonrpc "2.0"] 133 | [id id] 134 | [error 135 | (json:make-object 136 | [code code] 137 | [message (exit-reason->english reason)] 138 | [data (format "~s" reason)])]))) 139 | 140 | (define (make-pos line char) 141 | (json:make-object [line line] [character char])) 142 | 143 | (define (make-range start end) 144 | (json:make-object [start start] [end end])) 145 | 146 | (define (make-location uri range) 147 | (json:make-object [uri uri] [range range])) 148 | 149 | (define (make-text-edit range text) 150 | (json:make-object [range range] [newText text])) 151 | 152 | (define (make-progress token title render-msg) 153 | (match (progress:start title render-msg 154 | (lambda (msg) 155 | (rpc:fire-event "$/progress" 156 | (json:make-object 157 | [token token] 158 | [value msg]))) 159 | trace-expr) 160 | [#(ok ,pid) pid] 161 | [#(error ,reason) 162 | (trace-expr `(make-progress => ,(exit-reason->english reason))) 163 | #f])) 164 | 165 | (define (publish-diagnostics uri) 166 | (rpc:fire-event "textDocument/publishDiagnostics" 167 | (json:make-object 168 | [uri uri] 169 | [diagnostics (current-diagnostics)]))) 170 | 171 | (define (start-check uri cursor skip-delay?) 172 | (spawn 173 | (lambda () 174 | (unless skip-delay? 175 | (receive (after 1000 'ok))) 176 | (let ([text (cursor->string cursor)]) 177 | (check uri text skip-delay?) 178 | (publish-diagnostics uri) 179 | (unless skip-delay? 180 | (receive (after 30000 'ok))) 181 | (check-line-whitespace text #t report) 182 | (publish-diagnostics uri))))) 183 | 184 | (define (start-update-refs uri progress) 185 | (define pid 186 | (spawn 187 | (lambda () 188 | (with-gatekeeper-mutex $update-refs 'infinity 189 | (let* ([filename (uri->abs-path uri)] 190 | [text (utf8->string (read-file filename))] 191 | [annotated-code (read-code text)] 192 | [source-table (make-code-lookup-table text)]) 193 | (do-update-refs uri text annotated-code source-table)))))) 194 | (when progress 195 | (progress:inc-total progress) 196 | (spawn 197 | (lambda () 198 | (monitor pid) 199 | (receive 200 | [`(DOWN ,_ ,_ ,_) 201 | (progress:inc-done progress)])))) 202 | pid) 203 | 204 | (define current-diagnostics (make-process-parameter '())) 205 | 206 | (define (add-diagnostic d) 207 | (current-diagnostics (cons d (current-diagnostics)))) 208 | 209 | (define current-source-table (make-process-parameter #f)) 210 | 211 | (define (type->severity type) 212 | (match type 213 | [error 1] 214 | [warning 2] 215 | [info 3] 216 | [hint 4])) 217 | 218 | (define (bfp/efp->lsp-range table bfp efp) 219 | (let-values ([(bl bc) (fp->line/char table bfp)] 220 | [(el ec) (fp->line/char table efp)]) 221 | (let ([bl (- bl 1)] ; LSP is 0-based 222 | [el (- el 1)] 223 | [bc (- bc 1)] 224 | [ec (- ec 1)]) 225 | (make-range (make-pos bl bc) (make-pos el ec))))) 226 | 227 | (define (find-range code table line1 col1) 228 | (match (try 229 | (let ([fp (line/char->fp table line1 col1)]) 230 | (let-values ([(type value bfp efp) (read-token-near/fp code fp)]) 231 | (and (eq? type 'atomic) 232 | (bfp/efp->lsp-range table bfp efp))))) 233 | [`(catch ,reason) 234 | (trace-expr 235 | `(find-range ,line1 ,col1 => ,(exit-reason->english reason))) 236 | #f] 237 | [,result result])) 238 | 239 | (define (->lsp-range x) 240 | (match x 241 | [,line (guard (fixnum? line)) 242 | (let ([line (- line 1)]) ; LSP is 0-based 243 | (make-range (make-pos line 0) (make-pos (+ line 1) 0)))] 244 | [#(range ,start-line ,start-column ,end-line ,end-column) 245 | (guard (and (fixnum? start-line) (fixnum? start-column) 246 | (fixnum? end-line) (fixnum? end-column))) 247 | (let ([start-line (- start-line 1)] ; LSP is 0-based 248 | [end-line (- end-line 1)] 249 | [start-column (- start-column 1)] 250 | [end-column (- end-column 1)]) 251 | (make-range (make-pos start-line start-column) 252 | (make-pos end-line end-column)))] 253 | [#(near ,code ,line ,column) 254 | (cond 255 | [(not line) (->lsp-range 1)] 256 | [(not column) (->lsp-range line)] 257 | [(find-range code (current-source-table) line column)] 258 | [else 259 | (let ([line (- line 1)] ; LSP is 0-based 260 | [column (- column 1)]) 261 | (make-range (make-pos line column) (make-pos (+ line 1) 0)))])] 262 | [`(annotation [source ,src]) 263 | (bfp/efp->lsp-range (current-source-table) 264 | (source-object-bfp src) 265 | (source-object-efp src))])) 266 | 267 | (define (report x type fmt . args) 268 | (add-diagnostic 269 | (json:make-object 270 | [severity (type->severity type)] 271 | [message (apply format fmt args)] 272 | [range (->lsp-range x)]))) 273 | 274 | (define (check uri text skip-delay?) 275 | (match (try (read-code text)) 276 | [`(catch ,reason) 277 | (let ([table (make-code-lookup-table text)]) 278 | (spawn-update-refs uri #f table text) 279 | (let-values ([(line msg) (reason->line/msg reason table)]) 280 | (report line 'error msg)))] 281 | [,annotated-code 282 | (let ([source-table (make-code-lookup-table text)]) 283 | (spawn-update-refs uri annotated-code source-table text) 284 | (current-source-table source-table) 285 | (check-import/export annotated-code report) 286 | (run-optional-checkers uri skip-delay? annotated-code text report))])) 287 | 288 | (define (do-update-refs uri text annotated-code source-table) 289 | (let ([filename (uri->abs-path uri)] 290 | [refs (make-hashtable string-hash string=?)]) 291 | (define (key name line char) 292 | (format "~a:~a:~a" name line char)) 293 | (define (try-walk who walk code get-bfp meta) 294 | (match 295 | (try 296 | (walk code source-table 297 | (lambda (table name source) 298 | (let-values ([(line char) (fp->line/char table (get-bfp source))]) 299 | (let ([new (json:make-object 300 | [name (get-symbol-name name)] 301 | [line line] 302 | [char char] 303 | [meta meta])]) 304 | (hashtable-update! refs (key name line char) 305 | (lambda (old) 306 | (if old 307 | (json:merge old new) 308 | new)) 309 | #f)))))) 310 | [`(catch ,reason) 311 | (trace-expr `(,who => ,(exit-reason->english reason))) 312 | #f] 313 | [,_ #t])) 314 | (define (defns-anno) 315 | (and annotated-code 316 | (try-walk 'walk-defns walk-defns annotated-code source-object-bfp 317 | (json:make-object 318 | [definition 1] 319 | [anno-pass 1])))) 320 | (define (defns-re) 321 | (try-walk 'walk-defns-re walk-defns-re text car 322 | (json:make-object 323 | [definition 1] 324 | [regexp-pass 1]))) 325 | (define (refs-anno) 326 | (and annotated-code 327 | (try-walk 'walk-refs walk-refs annotated-code source-object-bfp 328 | (json:make-object 329 | [anno-pass 1])))) 330 | (define (refs-re) 331 | (try-walk 'walk-refs-re walk-refs-re text car 332 | (json:make-object 333 | [regexp-pass 1]))) 334 | (or (defns-anno) (defns-re)) 335 | (or (refs-anno) (refs-re)) 336 | (tower-client:update-references filename 337 | (vector->list (hashtable-values refs))) 338 | (event-mgr:notify (cons 'test-sync uri)))) 339 | 340 | (define (spawn-update-refs uri annotated-code source-table text) 341 | (spawn&link 342 | (lambda () 343 | (catch (do-update-refs uri text annotated-code source-table))))) 344 | 345 | (define (get-completions doc uri line char) 346 | (let ([line (+ line 1)] ; LSP is 0-based 347 | #;[char (+ char 1)]) ; ... but we want the preceding char 348 | (cond 349 | [(doc:get-value-near doc line char) => 350 | (lambda (prefix) 351 | (tower-client:get-completions (uri->abs-path uri) line char prefix))] 352 | [else '()]))) 353 | 354 | (define (get-definitions doc uri line char) 355 | (let ([line (+ line 1)] ; LSP is 0-based 356 | [char (+ char 1)]) 357 | (cond 358 | [(doc:get-value-near doc line char) => 359 | (lambda (name) 360 | (map 361 | (lambda (defn) 362 | (let ([uri (abs-path->uri (json:ref defn 'filename #f))] 363 | [line (- (json:ref defn 'line #f) 1)] ; LSP is 0-based 364 | [char (- (json:ref defn 'char #f) 1)]) 365 | (make-location uri 366 | (make-range 367 | (make-pos line char) 368 | (make-pos line (+ char (string-length name))))))) 369 | (tower-client:get-definitions (uri->abs-path uri) name)))] 370 | [else '()]))) 371 | 372 | (define (get-references doc uri line char) 373 | (let ([line (+ line 1)] ; LSP is 0-based 374 | [char (+ char 1)]) 375 | (cond 376 | [(doc:get-value-near doc line char) => 377 | (lambda (name) 378 | (map 379 | (lambda (ref) 380 | (let ([uri (abs-path->uri (json:ref ref 'filename #f))] 381 | [line (- (json:ref ref 'line #f) 1)] ; LSP is 0-based 382 | [char (- (json:ref ref 'char #f) 1)]) 383 | (make-location uri 384 | (make-range 385 | (make-pos line char) 386 | (make-pos line (+ char (string-length name))))))) 387 | (tower-client:get-references (uri->abs-path uri) name)))] 388 | [else '()]))) 389 | 390 | (define (highlight-references doc uri line char) 391 | (let ([line (+ line 1)] ; LSP is 0-based 392 | [char (+ char 1)]) 393 | (cond 394 | [(doc:get-value-near doc line char) => 395 | (lambda (name) 396 | (map 397 | (lambda (ref) 398 | (let ([line (- (json:ref ref 'line #f) 1)] ; LSP is 0-based 399 | [char (- (json:ref ref 'char #f) 1)]) 400 | (json:make-object 401 | [kind 1] ; Text 402 | [range 403 | (make-range 404 | (make-pos line char) 405 | (make-pos line (+ char (string-length name))))]))) 406 | (tower-client:get-local-references (uri->abs-path uri) name)))] 407 | [else '()]))) 408 | 409 | (define (indent-range doc range options) 410 | (let* ([start (or (and range (json:ref range '(start line) #f)) 0)] 411 | [end (or (and range (json:ref range '(end line) #f)) 412 | (most-positive-fixnum))] 413 | [end-char (or (and range (json:ref range '(end character) #f)) 414 | 0)] 415 | [end (if (zero? end-char) 416 | (- end 1) 417 | end)]) 418 | (trace-time 'indent 419 | (reverse 420 | (fold-indent (doc:get-text doc) '() 421 | (lambda (line old new acc) 422 | (let ([line (- line 1)]) ; LSP is 0-based 423 | (if (and (<= start line end) 424 | (not (string=? old new))) 425 | (cons 426 | (make-text-edit 427 | (make-range 428 | (make-pos line 0) 429 | (make-pos line (max (string-length old) 430 | (string-length new)))) 431 | new) 432 | acc) 433 | acc)))))))) 434 | 435 | (define (keep-file? fn) 436 | (let ([ext (path-extension fn)]) 437 | (or (member ext '("ss" "ms")) 438 | (let ([ip (open-binary-file-to-read fn)]) 439 | (on-exit (close-port ip) 440 | (and (eqv? (get-u8 ip) (char->integer #\#)) 441 | (eqv? (get-u8 ip) (char->integer #\!)) 442 | (let ([b (get-u8 ip)]) 443 | (or (eqv? b (char->integer #\space)) (eqv? b (char->integer #\/)))) 444 | (let ([ip (binary->utf8 ip)]) 445 | (let ([line (get-line ip)]) 446 | (and (not (eof-object? line)) 447 | (pregexp-match (re "swish|scheme|petite") line) 448 | #t))))))))) 449 | 450 | (define (find-files-external ff path) 451 | (trace-expr `(find-files-external ,ff ,path)) 452 | (call-with-values 453 | (lambda () 454 | (try (parameterize ([cd path]) 455 | (spawn-os-process (car ff) (cdr ff) (spawn values))))) 456 | (case-lambda 457 | [(fault) 458 | (trace-expr `(find-files => ,(exit-reason->english fault))) 459 | '()] 460 | [(to-stdin from-stdout from-stderr os-pid) 461 | (let ([to-stdin (binary->utf8 to-stdin)] 462 | [from-stdout (binary->utf8 from-stdout)] 463 | [from-stderr (binary->utf8 from-stderr)]) 464 | (on-exit (begin (close-input-port from-stdout) 465 | (close-input-port from-stderr)) 466 | (close-output-port to-stdin) 467 | (spawn 468 | (lambda () 469 | (let lp () 470 | (let ([line (get-line from-stderr)]) 471 | (unless (eof-object? line) 472 | (display line (trace-output-port)) 473 | (newline (trace-output-port)) 474 | (lp)))))) 475 | (let lp ([ls '()]) 476 | (match (get-line from-stdout) 477 | [#!eof (reverse ls)] 478 | [,fn 479 | (let ([fn (path-combine path fn)]) 480 | (if (and (regular-file? fn) (keep-file? fn)) 481 | (lp (cons fn ls)) 482 | (lp ls)))]))))]))) 483 | 484 | (define (find-files-default path) 485 | (filter-files path 486 | (lambda (dir) 487 | (cond 488 | [(string=? (path-last dir) ".git") #f] ; skip the actual repo tree 489 | [(file-exists? (path-combine dir ".git")) #f] ; skip repos 490 | [else #t])) 491 | keep-file?)) 492 | 493 | (define (find-files path) 494 | (let ([ff (config:find-files)]) 495 | (if ff 496 | (find-files-external ff path) 497 | (find-files-default path)))) 498 | 499 | (define (lsp-server:start&link) 500 | (define-state-tuple 501 | root-uri 502 | root-dir 503 | req->pid 504 | pid->req 505 | uri->doc 506 | client-cap 507 | requests 508 | ) 509 | (define shutdown-requested? #f) 510 | 511 | (define (init) 512 | `#(ok ,( make 513 | [root-uri #f] 514 | [root-dir #f] 515 | [req->pid (ht:make equal-hash equal? 516 | (lambda (x) (or (fixnum? x) (string? x))))] 517 | [pid->req (ht:make process-id eq? process?)] 518 | [uri->doc (ht:make string-hash string=? string?)] 519 | [client-cap #f] 520 | [requests (ht:make string-hash string=? string?)] 521 | ))) 522 | (define (terminate reason state) 'ok) 523 | (define (handle-call msg from state) 524 | (match msg 525 | [#(incoming-message ,msg) 526 | (let ([id (json:ref msg 'id #f)]) 527 | (cond 528 | [(not id) 529 | (let ([method (json:get msg 'method)] 530 | [params (json:get msg 'params)]) 531 | `#(reply ok ,(handle-notify method params state)))] 532 | [(and (string? id) (ht:ref ($state requests) id #f)) 533 | (trace-expr 'received-reply) 534 | (trace-msg msg) 535 | `#(reply ok ,($state copy* [requests (ht:delete requests id)]))] 536 | [else 537 | (let ([method (json:get msg 'method)] 538 | [params (json:get msg 'params)]) 539 | `#(reply ok ,(do-handle-request id method params state)))]))])) 540 | (define (handle-cast msg state) (match msg)) 541 | (define (handle-info msg state) 542 | (match msg 543 | [#(request-finished ,pid ,id ,result) 544 | (rpc:respond id result) 545 | `#(no-reply ,(delete-req id pid state))] 546 | [`(DOWN ,_ ,pid ,reason) 547 | (cond 548 | [(ht:ref ($state pid->req) pid #f) => 549 | (lambda (id) 550 | (rpc:respond-error id -32000 reason) 551 | `#(no-reply ,(delete-req id pid state)))] 552 | [else 553 | `#(no-reply ,state)])])) 554 | 555 | (define (delete-req id pid state) 556 | ($state copy* 557 | [req->pid (ht:delete req->pid id)] 558 | [pid->req (ht:delete pid->req pid)])) 559 | 560 | (define (updated uri change skip-delay? progress state) 561 | (define (doc-changed change cursor skip-delay?) 562 | ;; called from inside doc gen-server process 563 | (if change 564 | (start-check uri cursor skip-delay?) 565 | (start-update-refs uri progress))) 566 | (let-values ([(doc state) 567 | (cond 568 | [(ht:ref ($state uri->doc) uri #f) => 569 | (lambda (doc) (values doc state))] 570 | [else 571 | (match-let* 572 | ([#(ok ,pid) 573 | (watcher:start-child 'main-sup (gensym "document") 1000 574 | (lambda () (doc:start&link doc-changed)))]) 575 | (values pid 576 | ($state copy* [uri->doc (ht:set uri->doc uri pid)])))])]) 577 | (doc:updated doc change skip-delay?) 578 | state)) 579 | 580 | (define (do-handle-request id method params state) 581 | (match (try (handle-request id method params state)) 582 | [`(catch ,reason) 583 | (rpc:respond-error id -32000 reason) 584 | state] 585 | [#(ok ,result ,state) 586 | (rpc:respond id result) 587 | state] 588 | [#(ignore ,state) 589 | state] 590 | [#(spawn ,thunk ,state) 591 | (let* ([me self] 592 | [pid (spawn 593 | (lambda () 594 | (send me `#(request-finished ,self ,id ,(thunk)))))]) 595 | (monitor pid) 596 | ($state copy* 597 | [req->pid (ht:set req->pid id pid)] 598 | [pid->req (ht:set pid->req pid id)]))])) 599 | 600 | (define (handle-request id method params state) 601 | (match method 602 | ["initialize" 603 | ;;(trace-msg (json:make-object [method method] [params params])) 604 | (let* ([root-uri (json:get params 'rootUri)] 605 | [root-uri (and (string? root-uri) root-uri)] 606 | [root-dir (and root-uri (uri->abs-path root-uri))] 607 | [client-cap (json:get params 'capabilities)]) 608 | (tower-client:reset-directory root-dir) 609 | `#(ok 610 | ,(json:make-object 611 | [capabilities 612 | (json:make-object 613 | [textDocumentSync 614 | (json:make-object 615 | [openClose #t] 616 | [change 2] ; Incremental 617 | [willSave #f] 618 | [willSaveWaitUntil #f] 619 | [save (json:make-object [includeText #t])])] 620 | [hoverProvider #f] 621 | [completionProvider #t] 622 | [definitionProvider #t] 623 | [referencesProvider #t] 624 | [documentHighlightProvider #t] 625 | [documentFormattingProvider #t] 626 | [documentRangeFormattingProvider #t] 627 | )]) 628 | ,($state copy 629 | [root-uri root-uri] 630 | [root-dir root-dir] 631 | [client-cap client-cap])))] 632 | ["textDocument/hover" 633 | `#(ok #f ,state)] 634 | ["textDocument/completion" 635 | (let ([uri (json:get params '(textDocument uri))] 636 | [line (json:get params '(position line))] 637 | [char (json:get params '(position character))]) 638 | (cond 639 | [(ht:ref ($state uri->doc) uri #f) => 640 | (lambda (doc) 641 | `#(spawn ,(lambda () (get-completions doc uri line char)) ,state))] 642 | [else `#(ok () ,state)]))] 643 | ["textDocument/definition" 644 | (let ([uri (json:get params '(textDocument uri))] 645 | [line (json:get params '(position line))] 646 | [char (json:get params '(position character))]) 647 | (cond 648 | [(ht:ref ($state uri->doc) uri #f) => 649 | (lambda (doc) 650 | `#(spawn ,(lambda () (get-definitions doc uri line char)) ,state))] 651 | [else `#(ok () ,state)]))] 652 | ["textDocument/references" 653 | (let ([uri (json:get params '(textDocument uri))] 654 | [line (json:get params '(position line))] 655 | [char (json:get params '(position character))]) 656 | (cond 657 | [(ht:ref ($state uri->doc) uri #f) => 658 | (lambda (doc) 659 | `#(spawn ,(lambda () (get-references doc uri line char)) ,state))] 660 | [else `#(ok () ,state)]))] 661 | ["textDocument/documentHighlight" 662 | (let ([uri (json:get params '(textDocument uri))] 663 | [line (json:get params '(position line))] 664 | [char (json:get params '(position character))]) 665 | (cond 666 | [(ht:ref ($state uri->doc) uri #f) => 667 | (lambda (doc) 668 | `#(spawn ,(lambda () (highlight-references doc uri line char)) ,state))] 669 | [else `#(ok () ,state)]))] 670 | ["textDocument/formatting" 671 | (let ([uri (json:get params '(textDocument uri))] 672 | [options (json:get params 'options)]) 673 | (cond 674 | [(ht:ref ($state uri->doc) uri #f) => 675 | (lambda (doc) 676 | `#(ok ,(indent-range doc #f options) ,state))] 677 | [else `#(ok () ,state)]))] 678 | ["textDocument/rangeFormatting" 679 | (let ([uri (json:get params '(textDocument uri))] 680 | [range (json:get params 'range)] 681 | [options (json:get params 'options)]) 682 | (cond 683 | [(ht:ref ($state uri->doc) uri #f) => 684 | (lambda (doc) 685 | `#(ok ,(indent-range doc range options) ,state))] 686 | [else `#(ok () ,state)]))] 687 | ["shutdown" 688 | (set! shutdown-requested? #t) 689 | `#(ok #\nul ,state)] 690 | [,_ 691 | (fprintf (console-error-port) "*** Unhandled message ~s ***\n" method) 692 | (trace-msg (json:make-object [id id] [method method] [params params])) 693 | `#(ignore ,state)])) 694 | 695 | (define (handle-notify method params state) 696 | (match method 697 | ["$/cancelRequest" 698 | (let ([id (json:get params 'id)]) 699 | (cond 700 | [(ht:ref ($state req->pid) id #f) => 701 | (lambda (pid) 702 | (kill pid 'cancelled) 703 | (rpc:respond-error id -32800 "Cancelled") 704 | (delete-req id pid state))] 705 | [else state]))] 706 | ["initialized" 707 | ;; Always load the user configuration event if root-dir is 708 | ;; not specified. 709 | (output-env) 710 | (config:load-user) 711 | (cond 712 | [($state root-dir) => 713 | (lambda (dir) 714 | (config:load-project dir) 715 | (let ([progress (make-progress "enumerate-directories" 716 | "Analyze files" 717 | (lambda (done total) 718 | (format "~a/~a files" done total)))]) 719 | (trace-time 'enumerate-directories 720 | (fold-left 721 | (lambda (state fn) 722 | (updated (abs-path->uri fn) #f #t progress state)) 723 | state 724 | (find-files dir)))))] 725 | [else state])] 726 | ["textDocument/didOpen" 727 | (let ([doc (json:get params 'textDocument)]) 728 | (updated (json:get doc 'uri) (json:get doc 'text) #t #f state))] 729 | ["textDocument/didChange" 730 | (updated 731 | (json:get params '(textDocument uri)) 732 | (json:get params 'contentChanges) 733 | #f 734 | #f 735 | state)] 736 | ["textDocument/didSave" 737 | (updated 738 | (json:get params '(textDocument uri)) 739 | (json:get params 'text) 740 | #t 741 | #f 742 | state)] 743 | ["textDocument/didClose" state] 744 | ["$/setTrace" state] 745 | ["exit" (app:shutdown (if shutdown-requested? 0 1))] 746 | [,_ 747 | (fprintf (console-error-port) "*** Unhandled message ~s ***\n" method) 748 | (trace-msg (json:make-object [method method] [params params])) 749 | state])) 750 | 751 | (gen-server:start&link 'lsp-server)) 752 | 753 | (define (lsp-server:incoming-message msg) 754 | (gen-server:call 'lsp-server `#(incoming-message ,msg))) 755 | 756 | (define (lsp:sup-spec port-number ip op ignore-lhe?) 757 | `(#(tower-client 758 | ,(lambda () 759 | (tower-client:start&link 760 | (or port-number (http:get-port-number 'http)))) 761 | permanent 1000 worker) 762 | #(tower-log 763 | ,(lambda () 764 | (match (event-mgr:set-log-handler 765 | (lambda (e) 766 | (match e 767 | [(test-sync . ,_) #f] 768 | [,_ (tower-client:log (coerce e))])) 769 | (whereis 'tower-client)) 770 | [ok 771 | (event-mgr:flush-buffer) 772 | 'ignore] 773 | [,error 774 | (if ignore-lhe? 775 | 'ignore 776 | error)])) 777 | temporary 1000 worker) 778 | #(lsp-server ,lsp-server:start&link permanent 1000 worker) 779 | #(lsp:writer 780 | ,(lambda () (lsp:start-writer op)) 781 | permanent 1000 worker) 782 | #(lsp:reader 783 | ,(lambda () (lsp:start-reader ip lsp-server:incoming-message)) 784 | permanent 1000 worker))) 785 | 786 | (define (lsp:start-server port-number ip op) 787 | (trace-init) 788 | ;; Manually build the whole app-sup-spec. No real need to manage a 789 | ;; log database or statistics gathering for the LSP client. 790 | (app-sup-spec 791 | `(#(event-mgr ,event-mgr:start&link permanent 1000 worker) 792 | #(gatekeeper ,gatekeeper:start&link permanent 1000 worker) 793 | ,@(lsp:sup-spec port-number ip op #f) 794 | #(event-mgr-sentry ; Should be last 795 | ,(lambda () 796 | `#(ok ,(spawn&link 797 | (lambda () 798 | ;; Unregister event-mgr so that event-mgr:notify 799 | ;; no longer sends events to tower-log but to 800 | ;; the console. LSP is particularly hard to 801 | ;; debug during a crash, so more messages to the 802 | ;; console, the better. 803 | (process-trap-exit #t) 804 | (receive 805 | [`(EXIT ,_ ,_) (event-mgr:unregister)]))))) 806 | permanent 1000 worker) 807 | )) 808 | (fprintf (console-error-port) "~a\n" (versions->string)) 809 | (flush-output-port (console-error-port)) 810 | (app:start) 811 | (receive)) 812 | ) 813 | -------------------------------------------------------------------------------- /main.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (import 25 | (checkers) 26 | (chezscheme) 27 | (config) 28 | (config-params) 29 | (flycheck) 30 | (indent) 31 | (json) 32 | (keywords) 33 | (lsp) 34 | (software-info) 35 | (swish imports) 36 | (tower) 37 | (tower-client)) 38 | 39 | (define tower-port-number 51342) 40 | 41 | (define cli 42 | (cli-specs 43 | default-help 44 | [doctor --doctor bool "check your system for potential problems"] 45 | [lsp --lsp bool "start Language Server Protocol mode"] 46 | [format --format (string "") 47 | '("format specifiers that include the following" 48 | "substitution strings:" 49 | "%file, %type, %line, %column, %bfp, %efp, %msg")] 50 | [regexp-pass -r (list "" "") 51 | "report matches as ={info|warning|error}"] 52 | [indent --indent bool "indent files (edit in-place)"] 53 | [tower --tower bool "start tower server"] 54 | [tower-db --tower-db (string "") "save tower database to "] 55 | [update-keywords --update-keywords bool "update keywords"] 56 | [user-config --user-config bool "load user configuration"] 57 | [verbose -v count "show debug messages (tower and indent only)"] 58 | [version --version bool "print version information"] 59 | [files (list . "file") "check file"])) 60 | 61 | (software-info:install) 62 | (let* ([opt (parse-command-line-arguments cli)] 63 | [files (or (opt 'files) '())]) 64 | (define (regexp-opt->config) 65 | (let lp ([ls (or (opt 'regexp-pass) '())]) 66 | (match ls 67 | [() '()] 68 | [(,type ,regexp . ,rest) 69 | (cons `(regexp ,type ,regexp) (lp rest))]))) 70 | (cond 71 | [(opt 'help) 72 | (display-help (app:name) cli (opt)) 73 | (exit 0)] 74 | [(opt 'version) 75 | (display (versions->string)) 76 | (exit 0)] 77 | [(opt 'doctor) 78 | (config-output-port (console-output-port)) 79 | (trace-output-port (console-output-port)) 80 | (display (versions->string)) 81 | (newline) 82 | (output-env) 83 | (config:load-user) 84 | (newline) 85 | (printf "Current directory: ~a\n" (cd)) 86 | (let () 87 | (define (find-repo dir) 88 | (if (file-exists? (path-combine dir ".git")) 89 | dir 90 | (let ([parent (path-parent dir)]) 91 | (if (string=? parent dir) 92 | #f 93 | (find-repo parent))))) 94 | (let ([repo (find-repo (cd))]) 95 | (cond 96 | [repo 97 | (printf "Nearest repository: ~a\n" repo) 98 | (newline) 99 | (config:load-project repo)] 100 | [else 101 | (printf "No repository found\n")]))) 102 | (exit 0)] 103 | [(opt 'lsp) 104 | (config-output-port (console-error-port)) 105 | (optional-checkers (make-optional-passes (regexp-opt->config))) 106 | (lsp:start-server tower-port-number (console-input-port) (console-output-port))] 107 | [(opt 'tower) 108 | (let ([verbose (opt 'verbose)] 109 | [tower-db (opt 'tower-db)]) 110 | (cond 111 | [(not (tower:running? tower-port-number)) 112 | (tower:start-server verbose tower-db tower-port-number)] 113 | [verbose 114 | (match-let* ([#(ok ,pid) (tower-client:start&link tower-port-number)]) 115 | (unlink pid) 116 | (tower-client:shutdown-server) 117 | (kill pid 'shutdown)) 118 | (let lp ([n 1]) 119 | (receive (after 200 'ok)) 120 | (cond 121 | [(not (tower:running? tower-port-number)) 'ok] 122 | [(< n 10) (lp (+ n 1))] 123 | [else (errorf #f "Tower is still running.")])) 124 | (tower:start-server verbose tower-db tower-port-number)] 125 | [else 126 | (errorf #f "Tower is already running.")]))] 127 | [(opt 'update-keywords) 128 | (let ([keywords 129 | (get-keywords 130 | (lambda (reason) 131 | (fprintf (console-error-port) "~a\n" (exit-reason->english reason)) 132 | (flush-output-port (console-error-port))))]) 133 | (match-let* ([#(ok ,pid) (tower-client:start&link tower-port-number)]) 134 | (unlink pid) 135 | (tower-client:update-keywords keywords)))] 136 | [(and (opt 'indent) (not (null? files))) 137 | (let ([verbose (opt 'verbose)]) 138 | (for-each 139 | (lambda (filename) 140 | (let* ([text (utf8->string (read-file filename))] 141 | [start (erlang:now)] 142 | [indented (indent text)] 143 | [end (erlang:now)]) 144 | (cond 145 | [(string=? text indented) 146 | (printf "Unchanged")] 147 | [else 148 | (printf "Formatted") 149 | (let ([mode (get-mode filename)]) 150 | (rename-path filename (string-append filename "~")) 151 | (let ([op (open-file-to-write filename)]) 152 | (on-exit (close-port op) 153 | (display indented op))) 154 | (set-file-mode filename mode))]) 155 | (when verbose 156 | (printf " ~6:D LOC ~4d ms" 157 | (let ([ip (open-input-string text)]) 158 | (let lp ([total 0]) 159 | (let ([x (get-char ip)]) 160 | (if (eof-object? x) 161 | total 162 | (lp (if (eq? x #\newline) 163 | (+ total 1) 164 | total)))))) 165 | (- end start))) 166 | (printf " ~a\n" filename) 167 | )) 168 | files))] 169 | [(null? files) 170 | (display-help (app:name) cli (opt)) 171 | (exit 0)] 172 | [else 173 | (optional-checkers (make-optional-passes (regexp-opt->config))) 174 | (when (opt 'user-config) 175 | (config:load-user)) 176 | (report-format 177 | (compile-format 178 | (or (opt 'format) "%file: line %line: %msg"))) 179 | (exit 180 | (fold-left 181 | (lambda (acc file) 182 | (max acc (flycheck:process-file file))) 183 | 0 184 | files))])) 185 | -------------------------------------------------------------------------------- /os-process.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2023 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (os-process) 24 | (export 25 | os-process:start&link 26 | os-process:stop 27 | os-process:write 28 | ) 29 | (import 30 | (chezscheme) 31 | (swish imports) 32 | ) 33 | 34 | (define (os-process:start&link cmd args type get put get-trace) 35 | (gen-server:start&link #f cmd args type get put get-trace)) 36 | 37 | (define (os-process:write who data) 38 | (gen-server:call who `#(write ,data) 'infinity)) 39 | 40 | (define (os-process:stop who exit-status) 41 | (gen-server:call who `#(stop ,exit-status))) 42 | 43 | (define-state-tuple 44 | os-pid 45 | ip 46 | op 47 | ep 48 | put ; (lambda (op data) ...) 49 | exit-status 50 | reader ; pid 51 | tracer ; pid 52 | ) 53 | 54 | (define (init cmd args type get put get-trace) 55 | (define me self) 56 | (let*-values 57 | ([(op ip ep os-pid) (spawn-os-process cmd args me)] 58 | [(ip op ep) 59 | (match type 60 | [binary (values ip op ep)] 61 | [utf8 (values (binary->utf8 ip) 62 | (binary->utf8 op) 63 | (binary->utf8 ep))])]) 64 | (process-trap-exit #t) 65 | (unless put 66 | (force-close-output-port op)) 67 | `#(ok 68 | ,( make 69 | [os-pid os-pid] 70 | [ip ip] 71 | [op op] 72 | [ep ep] 73 | [put put] 74 | [exit-status 1] 75 | [reader (spawn&link (lambda () (get ip me)))] 76 | [tracer (spawn&link (lambda () (get-trace ep me)))] 77 | )))) 78 | 79 | (define (terminate reason state) 80 | ($state open [os-pid ip op ep exit-status reader tracer]) 81 | (when os-pid 82 | (osi_kill* os-pid exit-status)) 83 | (when (memq reason '(normal shutdown)) 84 | (kill reader 'shutdown) 85 | (kill tracer 'shutdown)) 86 | (try (close-input-port ip)) 87 | (try (close-input-port ep)) 88 | (force-close-output-port op)) 89 | 90 | (define (handle-call msg from state) 91 | (match msg 92 | [#(write ,data) 93 | ($state open [op put]) 94 | (put op data) 95 | (flush-output-port op) 96 | `#(reply ok ,state)] 97 | [#(stop ,exit-status) 98 | `#(stop normal normal ,($state copy [exit-status exit-status]))])) 99 | 100 | (define (handle-cast msg state) (match msg)) 101 | 102 | (define (handle-info msg state) 103 | (match msg 104 | [`(EXIT ,from ,reason) 105 | `#(stop ,reason ,state)] 106 | [#(process-terminated ,os-pid ,exit-status ,term-signal) 107 | `#(stop 108 | ,(if (zero? term-signal) 109 | 'normal 110 | msg) 111 | ,($state copy [os-pid #f] [exit-status exit-status]))])) 112 | ) 113 | -------------------------------------------------------------------------------- /progress.ms: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2021 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (import 24 | (progress) 25 | (software-info)) 26 | 27 | (software-info:install) 28 | 29 | (isolate-mat progress () 30 | (define (get-one) (receive (after 200 #f) [,msg msg])) 31 | (define prev-ts #f) 32 | (define (check title kind percentage message min-delta) 33 | (match-let* 34 | ([#(send ,timestamp ,msg) (get-one)] 35 | [,@title (json:ref msg 'title #f)] 36 | [,@kind (json:ref msg 'kind #f)] 37 | [,@percentage (json:ref msg 'percentage #f)] 38 | [,@message (json:ref msg 'message #f)] 39 | [,delta-ts (if prev-ts 40 | (- timestamp prev-ts) 41 | 0)]) 42 | (when min-delta 43 | (assert (<= min-delta delta-ts (+ min-delta 50)))) 44 | (set! prev-ts timestamp) 45 | msg)) 46 | 47 | (match-let* 48 | ([,title "My Progress"] 49 | [,me self] 50 | [#(ok ,pid) 51 | (progress:start title 52 | (lambda (done total) (format "~a/~a cases" done total)) 53 | (lambda (msg) (send me `#(send ,(erlang:now) ,msg))) 54 | (lambda (expr) (void)))] 55 | [#f (get-one)] 56 | [ok (progress:inc-total pid)] 57 | [,msg (check title "begin" 0 #f 0)] 58 | [ok (progress:inc-total pid)] 59 | [ok (progress:inc-total pid)] 60 | [,msg (check #f "report" 0 "0/3 cases" 100)] 61 | [ok (progress:inc-done pid)] 62 | [,msg (check #f "report" 33 "1/3 cases" 100)] 63 | [ok (progress:inc-done pid)] 64 | [,msg (check #f "report" 66 "2/3 cases" 100)] 65 | [ok (progress:inc-total pid)] 66 | [,msg (check #f "report" 66 "2/4 cases" 100)] ; percentage does not go down 67 | [ok (progress:inc-done pid)] 68 | [,msg (check #f "report" 75 "3/4 cases" 100)] 69 | [ok (progress:inc-done pid)] 70 | [ok (progress:inc-total pid)] 71 | [ok (progress:inc-total pid)] 72 | [ok (progress:inc-done pid)] 73 | [,msg (check #f "report" 83 "5/6 cases" 100)] ; only one update 74 | [ok (receive (after 150 'ok))] 75 | [#f (get-one)] ; no progress yields no messages. 76 | [ok (progress:inc-done pid)] 77 | [,msg (check #f "report" 100 "6/6 cases" #f)] 78 | [,msg (check #f "end" #f #f 0)] 79 | [ok (progress:inc-done pid)] ; No messages after complete 80 | [#f (get-one)] 81 | ;; Coverage: Make sure we don't divide by zero 82 | [,_ (set! prev-ts #f)] 83 | [#(ok ,pid) 84 | (progress:start title 85 | (lambda (done total) (format "~a/~a cases" done total)) 86 | (lambda (msg) (send me `#(send ,(erlang:now) ,msg))) 87 | (lambda (expr) (void)))] 88 | [#f (get-one)] 89 | [ok (progress:inc-done pid)] 90 | [ok (progress:inc-done pid)] 91 | [ok (progress:inc-done pid)] 92 | [,msg (check title "begin" 0 #f 0)] 93 | [,msg (check #f "report" 0 "3/0 cases" 100)] 94 | [,msg (check #f "end" #f #f 0)]) 95 | 'ok)) 96 | -------------------------------------------------------------------------------- /progress.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2021 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (progress) 24 | (export 25 | progress:inc-done 26 | progress:inc-total 27 | progress:start 28 | ) 29 | (import 30 | (chezscheme) 31 | (swish imports) 32 | ) 33 | (define (progress:start title render-msg send-msg trace-expr) 34 | (define-state-tuple 35 | start-time 36 | wake-time 37 | max-reported 38 | total 39 | done 40 | ) 41 | (define (no-reply state) 42 | `#(no-reply ,state ,(or ($state wake-time) 'infinity))) 43 | (define (wake-at old) 44 | (or old (+ (erlang:now) 100))) 45 | (define (start-at old) 46 | (or old 47 | (begin 48 | (send-msg 49 | (json:make-object 50 | [kind "begin"] 51 | [title title] 52 | [percentage 0])) 53 | (erlang:now)))) 54 | 55 | (define (init) 56 | `#(ok 57 | ,( make 58 | [start-time #f] 59 | [wake-time #f] 60 | [max-reported 0] 61 | [total 0] 62 | [done 0]))) 63 | (define (terminate reason state) 64 | ($state open [start-time]) 65 | (when start-time 66 | (send-msg (json:make-object [kind "end"])) 67 | (trace-expr `(time ,title ,(- (erlang:now) start-time) ms)))) 68 | (define (handle-call msg from state) (match msg)) 69 | (define (handle-cast msg state) 70 | (match msg 71 | [inc-total 72 | (no-reply 73 | ($state copy* 74 | [start-time (start-at start-time)] 75 | [wake-time (wake-at wake-time)] 76 | [total (fx+ total 1)]))] 77 | [inc-done 78 | (no-reply 79 | ($state copy* 80 | [start-time (start-at start-time)] 81 | [wake-time (wake-at wake-time)] 82 | [done (fx+ done 1)]))])) 83 | (define (handle-info msg state) 84 | (match msg 85 | [timeout 86 | ( open state [max-reported total done]) 87 | (let ([msg (render-msg done total)] 88 | [percent 89 | (max max-reported 90 | (min 100 91 | (if (zero? total) 92 | 0 93 | (floor (* (/ done total) 100)))))]) 94 | (send-msg 95 | (json:make-object 96 | [kind "report"] 97 | [message msg] 98 | [percentage percent])) 99 | (let ([state ($state copy [max-reported percent] [wake-time #f])]) 100 | (if (< done total) 101 | (no-reply state) 102 | `#(stop normal ,state))))])) 103 | (gen-server:start #f)) 104 | 105 | (define (progress:inc-total who) 106 | (gen-server:cast who 'inc-total)) 107 | 108 | (define (progress:inc-done who) 109 | (gen-server:cast who 'inc-done)) 110 | ) 111 | -------------------------------------------------------------------------------- /read.ms: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2021 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (import 24 | (read) 25 | (software-info)) 26 | 27 | (software-info:install) 28 | 29 | (isolate-mat definitions () 30 | (define (extract-name str) 31 | (let ([result #f]) 32 | (walk-defns-re str 'no-table 33 | (lambda (table name source) 34 | (set! result name))) 35 | result)) 36 | 37 | (match-let* 38 | (["f" (extract-name "(define (f x) x)")] 39 | ["f" (extract-name "(define f (lambda (x) x))")] 40 | ["f" (extract-name "(define-syntax f (syntax-rules () ...))")] 41 | ["f" (extract-name "(define-syntax (f x) (syntax-case x () ...))")] 42 | ["opt" (extract-name "(define-options opt ...)")] 43 | [#f (extract-name "(define- f x)")] 44 | [#f (extract-name "(definegarbage f x)")] 45 | [#f (extract-name "(define-inline 2 x ...)")] 46 | ["x" (extract-name "(set! x 5)")] 47 | ["x" (extract-name "(set-who! x 'me)")] 48 | [#f (extract-name "(setgarbage! x 'me)")] 49 | [#f (extract-name "(set-! x 'me)")] 50 | [#f (extract-name "(set! (x) 5)")] 51 | [#f (extract-name "(set-who! (x) 'me)")] 52 | [#f (extract-name "(set!bad x 5)")] 53 | ["f" (extract-name "(trace-define (f x) x)")] 54 | ["f" (extract-name "(trace-define-syntax (f x) x)")] 55 | [#f (extract-name "(trace-trace-define (f x) x)")] 56 | [#f (extract-name "(tracedefine (f x) x)")] 57 | ["f" (extract-name "(define-who f x)")] 58 | ["f" (extract-name "(meta define (f x) x)")] 59 | ["f" (extract-name "(meta define f (lambda (x) x)")] 60 | ["f" (extract-name "(meta define-record f (x))")] 61 | [#f (extract-name "(meta meta define (f x) x)")] 62 | [#f (extract-name "(meta set! x y)")] 63 | [#f (extract-name "(field-set! x y)")] 64 | [#f (extract-name "(set-field! x y)")] 65 | [#f (extract-name "(set-top-level-value! 'x y)")] 66 | ) 67 | ;; Check that all (scheme) exports except set! return #f 68 | (for-each 69 | (lambda (x) 70 | (when (and (not (eq? x 'set!)) 71 | (pregexp-match "set.*!" (symbol->string x))) 72 | (let ([expr (format "(~a x y)" x)]) 73 | (match (extract-name expr) 74 | [#f 'ok] 75 | [,result 76 | (printf "~a: ~a\n" result expr) 77 | (throw `#(failed ,result ,expr))])))) 78 | (library-exports '(scheme))) 79 | 'ok)) 80 | -------------------------------------------------------------------------------- /read.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (read) 24 | (export 25 | annotation 26 | fp->line 27 | fp->line/char 28 | get-symbol-name 29 | line/char->fp 30 | make-code-lookup-table 31 | read-code 32 | read-token-near/col 33 | read-token-near/fp 34 | reason->line/msg 35 | walk-annotations 36 | walk-defns 37 | walk-defns-re 38 | walk-refs 39 | walk-refs-re 40 | ) 41 | (import 42 | (chezscheme) 43 | (config-params) 44 | (swish imports)) 45 | 46 | ;; give us enough access to internal annotation record for match 47 | (define-syntax annotation 48 | (let* ([annotated (read-bytevector "sneak" (string->utf8 "123"))] 49 | [rtd (record-rtd (car annotated))]) 50 | (make-compile-time-value `(_ ,rtd _ _)))) 51 | 52 | (define (read-code code) 53 | ;; We make up a completely fake SFD. locate-source may attempt to 54 | ;; load the code from file again to compute and check a crc. We 55 | ;; explicitly avoid locate-source, and so we only need the SFD for 56 | ;; get-datum/annotations. 57 | (let ([sfd (make-source-file-descriptor (gensym->unique-string (gensym)) 58 | (open-bytevector-input-port '#vu8()))] 59 | [ip (open-string-input-port code)]) 60 | ;; Explicitly skip a #! line at the beginning of the file. 61 | (let ([start (port-position ip)]) 62 | (if (and (eqv? (get-char ip) #\#) 63 | (eqv? (get-char ip) #\!) 64 | (let ([x (peek-char ip)]) 65 | (or (eqv? x #\space) 66 | (eqv? x #\/)))) 67 | (let lp () 68 | (let ([x (read-char ip)]) 69 | (unless (or (eof-object? x) 70 | (eqv? x #\newline)) 71 | (lp)))) 72 | (set-port-position! ip start))) 73 | (let f ([fp (port-position ip)]) 74 | (let-values ([(x offset) (get-datum/annotations ip sfd fp)]) 75 | (if (= offset fp) 76 | '() 77 | (cons x (f offset))))))) 78 | 79 | (define (make-code-lookup-table code) 80 | (let ([ip (open-input-string code)]) 81 | (let lp ([fp 0] [fps '(0)]) 82 | (let ([ch (read-char ip)]) 83 | (cond 84 | [(eof-object? ch) 85 | (close-input-port ip) 86 | (list->vector (reverse fps))] 87 | [(eqv? ch #\newline) 88 | (let ([fp (fx+ fp 1)]) 89 | (lp fp (cons fp fps)))] 90 | [else 91 | (lp (fx+ fp 1) fps)]))))) 92 | 93 | (define (line/char->fp table line char) 94 | (+ (vector-ref table (fx- line 1)) (fx- char 1))) 95 | 96 | (define (fp->line/char table fp) 97 | (let loop ([lo 0] [hi (vector-length table)]) 98 | (if (fx= (fx+ 1 lo) hi) 99 | (values hi (fx+ 1 (fx- fp (vector-ref table lo)))) 100 | (let ([mid (fxsra (fx+ lo hi) 1)]) 101 | (if (< fp (vector-ref table mid)) 102 | (loop lo mid) 103 | (loop mid hi)))))) 104 | 105 | (define (fp->line table fp) 106 | (let-values ([(line char) (fp->line/char table fp)]) 107 | line)) 108 | 109 | (define (reason->line/msg reason code/table) 110 | (let ([msg (exit-reason->english reason)]) 111 | (match (pregexp-match (re "[^:]*:\\s*((.*) (?:at|near) (line|char) (\\d+))") msg) 112 | [(,_ ,_ ,msg "line" ,line) 113 | (values (string->number line) msg)] 114 | [(,_ ,_ ,msg "char" ,fp) 115 | (guard code/table) 116 | (values 117 | (fp->line 118 | (if (string? code/table) 119 | (make-code-lookup-table code/table) 120 | code/table) 121 | (string->number fp)) 122 | msg)] 123 | [(,_ ,msg . ,_) (values 1 msg)] 124 | [,_ (values 1 msg)]))) 125 | 126 | (define (get-symbol-name x) 127 | (define (clean? s) 128 | (let ([len (string-length s)]) 129 | (let lp ([i 0]) 130 | (cond 131 | [(fx= i len) #t] 132 | [(char-whitespace? (string-ref s i)) #f] 133 | [else (lp (fx1+ i))])))) 134 | (cond 135 | [(gensym? x) (parameterize ([print-gensym #t]) (format "~s" x))] 136 | [(symbol? x) 137 | (let ([s (symbol->string x)]) 138 | (if (clean? s) 139 | s 140 | (format "|~a|" s)))] 141 | [else x])) 142 | 143 | (define (read-token-near/col str col1) 144 | (read-token-near/fp str (fx- col1 1))) 145 | 146 | (define (read-token-near/fp str fp) 147 | (let ([ip (open-input-string str)]) 148 | (let lp ([lt #f] [lv #f] [lb 0] [le 0]) 149 | (let-values ([(type value bfp efp) (read-token ip)]) 150 | (cond 151 | [(and (<= bfp fp) (< fp efp)) (values type value bfp efp)] 152 | [(or (> bfp fp) (eof-object? value)) (values lt lv lb le)] 153 | [else (lp type value bfp efp)]))))) 154 | 155 | (define (walk-annotations x proc) 156 | (let ([seen (make-eq-hashtable)]) 157 | (let walk ([x x]) 158 | (cond 159 | [(pair? x) 160 | (walk (car x)) 161 | (walk (cdr x))] 162 | [(vector? x) 163 | (do ([i 0 (+ i 1)]) ((= i (vector-length x))) 164 | (walk (vector-ref x i)))] 165 | [(annotation? x) 166 | (let ([cell (eq-hashtable-cell seen x #f)]) 167 | (unless (cdr cell) 168 | (set-cdr! cell #t) 169 | (proc x) 170 | (walk (annotation-expression x))))])))) 171 | 172 | (define identifier "[:*+A-Za-z0-9~&!?\\/<=>^%$@_.-]+") 173 | 174 | (define (defn-exprs) 175 | (list 176 | (format "(?:~a\\s+)?(?:trace-)?(?:~a)(?:-[\\S]+|\\s)?\\s+\\(?" 177 | identifier 178 | (join (cons "define" (map pregexp-quote (config:definition-keywords))) #\|)) 179 | "set(?:-who)?!\\s+")) 180 | 181 | (define (defn-regexp) 182 | ;; leading paren 183 | ;; non-capture, any defn form 184 | ;; capture, identifier 185 | (re (format "\\((?:~a)(~a)" (join (defn-exprs) #\|) identifier))) 186 | 187 | (define (walk-defns-re text table proc) 188 | (define defn-re (defn-regexp)) 189 | (let lp ([start 0]) 190 | (match (pregexp-match-positions defn-re text start) 191 | [(,_ (,start . ,end)) 192 | (let ([name (substring text start end)]) 193 | (unless (string->number name) 194 | (proc table name (cons start end)))) 195 | (lp end)] 196 | [,_ (void)]))) 197 | 198 | (define (walk-defns annotated-code table proc) 199 | (define defines (join (cons "define" (map pregexp-quote (config:definition-keywords))) #\|)) 200 | (define defun-match-regexp 201 | (re (format "^(?:trace-)?(?:~a)(?:-[\\S]+)?" defines))) 202 | (define def-match-regexp 203 | (re (format "^(?:trace-)?(?:~a)(?:-[\\S]+)?|^set(?:-who)?!" defines))) 204 | (define local-keywords (make-eq-hashtable)) 205 | (define (keyword? keyword mre) 206 | (and (symbol? keyword) 207 | (or (eq-hashtable-ref local-keywords keyword #f) 208 | (let ([str (symbol->string keyword)]) 209 | (match (pregexp-match mre str) 210 | [#f #f] 211 | [,_ 212 | (eq-hashtable-set! local-keywords keyword #t) 213 | #t]))))) 214 | (define (guarded name name.anno) 215 | (cond 216 | [(not (symbol? name)) (void)] 217 | [(not (annotation? name.anno)) (void)] 218 | [else (proc table name (annotation-source name.anno))])) 219 | (walk-annotations annotated-code 220 | (lambda (x) 221 | (match x 222 | [`(annotation [stripped (,keyword (,name . ,_) . ,_)] 223 | [expression 224 | (,_ `(annotation [expression (,name.anno . ,_)]) . ,_)]) 225 | (guard (keyword? keyword defun-match-regexp)) 226 | (guarded name name.anno)] 227 | [`(annotation [stripped (,keyword ,name . ,_)] 228 | [expression (,_ ,name.anno . ,_)]) 229 | (guard (keyword? keyword def-match-regexp)) 230 | (guarded name name.anno)] 231 | [`(annotation [stripped (,meta ,keyword (,name . ,_) . ,_)] 232 | [expression 233 | (,_ ,_ `(annotation [expression (,name.anno . ,_)]) . ,_)]) 234 | (guard (and (symbol? meta) (keyword? keyword defun-match-regexp))) 235 | (guarded name name.anno)] 236 | [`(annotation [stripped (,meta ,keyword ,name . ,_)] 237 | [expression (,_ ,_ ,name.anno . ,_)]) 238 | ;; Use defun here because set! is not valid with meta. 239 | (guard (and (symbol? meta) (keyword? keyword defun-match-regexp))) 240 | (guarded name name.anno)] 241 | [,_ (void)])))) 242 | 243 | (define ref-regexp (re identifier)) 244 | 245 | (define (walk-refs-re text table proc) 246 | (let lp ([start 0]) 247 | (match (pregexp-match-positions ref-regexp text start) 248 | [((,start . ,end)) 249 | (let ([name (substring text start end)]) 250 | (unless (string->number name) 251 | (proc table name (cons start end)))) 252 | (lp end)] 253 | [#f (void)]))) 254 | 255 | (define (walk-refs annotated-code table proc) 256 | (walk-annotations annotated-code 257 | (lambda (x) 258 | (match x 259 | [`(annotation ,source [stripped ,name]) 260 | (guard (symbol? name)) 261 | (proc table name source)] 262 | [,_ (void)])))) 263 | ) 264 | -------------------------------------------------------------------------------- /software-info.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (software-info) 24 | (export 25 | software-info:install 26 | versions->string 27 | ) 28 | (import 29 | (chezscheme) 30 | (swish imports) 31 | ) 32 | (define (software-info:install) 33 | (define (warn fn) 34 | (warningf 'software-info.ss "file ~s not found at compile time" fn) 35 | #f) 36 | (define key 'swish-lint) 37 | (software-product-name key "Swish Lint") 38 | (software-revision key (include-line "git.revision" warn)) 39 | (software-version key (include-line "git.tag" warn))) 40 | 41 | (define (output-version op key) 42 | (fprintf op "~11@a~@[ ~6@a~]~@[ (~a)~]\n" 43 | (software-product-name key) 44 | (software-version key) 45 | (software-revision key))) 46 | 47 | (define (versions->string) 48 | (let ([op (open-output-string)]) 49 | (output-version op 'swish-lint) 50 | (output-version op 'swish) 51 | (output-version op 'chezscheme) 52 | (get-output-string op))) 53 | ) 54 | -------------------------------------------------------------------------------- /testing/common.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2024 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (testing common) 24 | (export 25 | with-tmp-dir 26 | write-script 27 | ) 28 | (import 29 | (chezscheme) 30 | (swish imports) 31 | ) 32 | (define-syntax with-tmp-dir 33 | (syntax-rules () 34 | [(_ e0 e1 ...) 35 | (parameterize ([tmp-dir (path-combine (base-dir) "tmp")]) 36 | e0 e1 ... 37 | (remove-directory (tmp-dir)))])) 38 | 39 | (define (write-script fn exprs) 40 | (let ([op (open-file-to-replace (make-directory-path fn))]) 41 | (on-exit (close-port op) 42 | (fprintf op "#!/usr/bin/env swish\n") 43 | (for-each (lambda (x) (write x op) (newline op)) exprs))) 44 | (set-file-mode fn #o777)) 45 | ) 46 | -------------------------------------------------------------------------------- /testing/pipe.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2022 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (testing pipe) 24 | (export 25 | make-pipe 26 | ) 27 | (import 28 | (chezscheme) 29 | (swish imports) 30 | ) 31 | (define (await-read) 32 | (receive 33 | [close (void)] 34 | [#(read ,rbv ,rstart ,rn ,reader) 35 | (receive 36 | [close (void)] 37 | [#(write ,wbv ,wstart ,wn ,writer) 38 | (let ([count (min rn wn)]) 39 | (bytevector-copy! wbv wstart rbv rstart count) 40 | (let ([msg (cons self count)]) 41 | (send writer msg) 42 | (send reader msg)) 43 | (await-read))])])) 44 | 45 | (define (make-pipe name) 46 | (let ([pid (spawn await-read)]) 47 | (define (close) (send pid 'close)) 48 | (values 49 | (make-custom-binary-input-port name 50 | (lambda (bv start n) 51 | (let ([m (monitor pid)]) 52 | (send pid `#(read ,bv ,start ,n ,self)) 53 | (receive 54 | [(,@pid . ,count) 55 | (demonitor&flush m) 56 | count] 57 | [`(DOWN ,@m ,_ ,_) 0]))) 58 | #f #f close) 59 | (make-custom-binary-output-port name 60 | (lambda (bv start n) 61 | (let ([m (monitor pid)]) 62 | (send pid `#(write ,bv ,start ,n ,self)) 63 | (receive 64 | [(,@pid . ,count) 65 | (demonitor&flush m) 66 | count] 67 | [`(DOWN ,@m ,_ ,_) 0]))) 68 | #f #f close)))) 69 | ) 70 | -------------------------------------------------------------------------------- /testing/rpc.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2022 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (library (testing rpc) 25 | (export 26 | rpc-client:call 27 | rpc-client:message 28 | rpc-client:notify 29 | rpc-client:send 30 | rpc-client:set-event-handler 31 | rpc-client:start&link 32 | ) 33 | (import 34 | (chezscheme) 35 | (swish imports) 36 | ) 37 | 38 | (define (rpc-reply x) 39 | (cond 40 | [(json:ref x 'error #f) => 41 | (lambda (err) (make-fault (json:ref err 'message #f)))] 42 | [else 43 | (let ([res (json:ref x 'result #!bwp)]) 44 | (when (eq? res #!bwp) 45 | (throw `#(missing-result ,x))) 46 | res)])) 47 | 48 | (define (rpc-client:start&link name write-msg) 49 | (define-state-tuple 50 | id 51 | id-map ; id -> (lambda (id reply) ...) 52 | event-handlers ; ( ...) 53 | ) 54 | (define-tuple type pred pid mon) 55 | (define (init) 56 | `#(ok ,( make 57 | [id 0] 58 | [id-map (ht:make values eq? fixnum?)] 59 | [event-handlers '()]))) 60 | (define (terminate reason state) 'ok) 61 | 62 | (define (handle-call msg from state) 63 | (match msg 64 | [#(send ,msg ,callback) 65 | (let ([id (fx+ ($state id) 1)]) 66 | (json:set! msg 'id id) 67 | (write-msg msg) 68 | `#(reply ok 69 | ,($state copy 70 | [id id] 71 | [id-map (ht:set ($state id-map) id callback)])))] 72 | [#(call ,msg) 73 | (let ([callback (lambda (id reply) (gen-server:reply from reply))] 74 | [id (fx+ ($state id) 1)]) 75 | (json:set! msg 'id id) 76 | (write-msg msg) 77 | `#(no-reply 78 | ,($state copy 79 | [id id] 80 | [id-map (ht:set ($state id-map) id callback)])))] 81 | [#(notify ,msg) 82 | (write-msg msg) 83 | `#(reply ok ,state)] 84 | [#(set-event-handler ,type ,pred ,pid) 85 | `#(reply ok 86 | ,($state copy* 87 | [event-handlers 88 | (cons ( make 89 | [type type] 90 | [pred pred] 91 | [pid pid] 92 | [mon (monitor pid)]) 93 | (remove-type type event-handlers))]))])) 94 | (define (handle-cast msg state) (match msg)) 95 | (define (handle-info msg state) 96 | (match msg 97 | [#(message ,msg) 98 | (match (json:ref msg 'id #f) 99 | [#f 100 | (call-event-handler msg ($state event-handlers)) 101 | `#(no-reply ,state)] 102 | [,id 103 | (match (ht:ref ($state id-map) id #f) 104 | [#f 105 | (fprintf (console-error-port) "Unexpected message\n") 106 | (json:write (console-error-port) msg 0) 107 | (newline (console-error-port)) 108 | (flush-output-port (console-error-port)) 109 | `#(no-reply ,state)] 110 | [,callback 111 | (let ([reply (rpc-reply msg)] 112 | [state ($state copy 113 | [id-map (ht:delete ($state id-map) id)])]) 114 | (callback id reply) 115 | `#(no-reply ,state))])])] 116 | [`(DOWN ,mon ,pid ,reason) 117 | `#(no-reply 118 | ,($state copy* 119 | [event-handlers (remove-mon mon event-handlers)]))])) 120 | (define (call-event-handler event event-handlers) 121 | (match event-handlers 122 | [() #f] 123 | [(`( ,pred ,pid) . ,rest) 124 | (cond 125 | [(pred event) => (lambda (value) (send pid value))] 126 | [else (call-event-handler event rest)])])) 127 | (define (remove-type type event-handlers) 128 | (match event-handlers 129 | [() '()] 130 | [(`( [type ,@type] ,mon) . ,rest) 131 | (demonitor&flush mon) 132 | rest] 133 | [(,first . ,rest) (cons first (remove-type type rest))])) 134 | (define (remove-mon mon event-handlers) 135 | (match event-handlers 136 | [() '()] 137 | [(`( [mon ,@mon]) . ,rest) rest] 138 | [(,first . ,rest) (cons first (remove-mon mon rest))])) 139 | (gen-server:start&link name)) 140 | 141 | (define (rpc-client:send who msg callback) 142 | (gen-server:call who `#(send ,msg ,callback))) 143 | 144 | (define (rpc-client:call who msg) 145 | (gen-server:call who `#(call ,msg) 'infinity)) 146 | 147 | (define (rpc-client:notify who msg) 148 | (gen-server:call who `#(notify ,msg))) 149 | 150 | (define (rpc-client:set-event-handler who type pred pid) 151 | (gen-server:call who `#(set-event-handler ,type ,pred ,pid))) 152 | 153 | (define (rpc-client:message who msg) 154 | (send who `#(message ,msg))) 155 | ) 156 | -------------------------------------------------------------------------------- /tower-client.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (library (tower-client) 25 | (export 26 | abs-path->uri 27 | tower-client:call 28 | tower-client:get-completions 29 | tower-client:get-definitions 30 | tower-client:get-local-references 31 | tower-client:get-references 32 | tower-client:log 33 | tower-client:reset-directory 34 | tower-client:shutdown-server 35 | tower-client:start&link 36 | tower-client:update-keywords 37 | tower-client:update-references 38 | uri->abs-path 39 | ) 40 | (import 41 | (chezscheme) 42 | (swish imports) 43 | ) 44 | 45 | (define (uri->abs-path uri) 46 | (match (pregexp-match (re "file://(.*)") uri) 47 | [(,_ ,filename) 48 | (meta-cond 49 | [windows? 50 | (pregexp-replace* (re "\\\\") 51 | (match (pregexp-match (re "/([A-Za-z])%3[Aa](.*)") filename) 52 | [(,_ ,drive ,filename) 53 | (string-append (string-upcase drive) ":" filename)] 54 | [,_ 55 | filename]) 56 | "/")] 57 | [else filename])] 58 | [,_ (throw `#(unhandled-uri ,uri))])) 59 | 60 | (define (abs-path->uri path) 61 | (meta-cond 62 | [windows? 63 | (match (pregexp-match (re "^([A-Za-z]):(.*)") path) 64 | [#f 65 | ;; When testing it is useful to support Unix paths. 66 | (string-append "file://" 67 | (pregexp-replace* (re "\\\\") path "/"))] 68 | [(,_ ,drive ,filename) 69 | (string-append "file:///" 70 | (string-downcase drive) 71 | "%3A" 72 | (pregexp-replace* (re "\\\\") filename "/"))])] 73 | [else 74 | (string-append "file://" path)])) 75 | 76 | (define (tower-client:start&link port-number) 77 | (define-state-tuple 78 | ws 79 | id 80 | id-map ; id -> from 81 | sync-token 82 | ) 83 | (define (try-connect state) 84 | (match (try (ws:connect "localhost" port-number "/tower" self)) 85 | [`(catch ,_) #f] 86 | [,ws 87 | (sync ws state) 88 | ws])) 89 | (define (do-connect state) 90 | (cond 91 | [($state ws)] 92 | [(try-connect state)] 93 | [else 94 | ;; Explicitly generating the executable's name here. If this 95 | ;; code is running via Swish script, we want to make sure to 96 | ;; fire up the Tower correctly. 97 | (let ([cmd (path-combine (path-parent (app:path)) "swish-lint")]) 98 | (fprintf (trace-output-port) "Launching ~a\n" cmd) 99 | (spawn-os-process-detached cmd '("--tower")) 100 | (let lp ([n 1]) 101 | (receive (after 200 'ok)) 102 | (fprintf (trace-output-port) "Reconnecting...\n") 103 | (cond 104 | [(try-connect state)] 105 | [(< n 10) (lp (+ n 1))] 106 | [else (throw 'unable-to-connect)])))])) 107 | (define (sync ws state) 108 | (cond 109 | [($state sync-token) => 110 | (lambda (sync-token) 111 | (ws:send ws 112 | (json:object->bytevector 113 | (json:make-object 114 | [method "synchronize"] 115 | [params 116 | (json:make-object 117 | [sync-token sync-token])]))))])) 118 | (define (rpc-reply x) 119 | (cond 120 | [(json:ref x 'error #f) => 121 | (lambda (err) (make-fault (json:ref err 'message #f)))] 122 | [else 123 | (let ([res (json:ref x 'result #!bwp)]) 124 | (when (eq? res #!bwp) 125 | (throw `#(unhandled-message ,x))) 126 | res)])) 127 | (define (init) 128 | `#(ok ,( make 129 | [ws #f] 130 | [id 0] 131 | [id-map (ht:make values eq? fixnum?)] 132 | [sync-token #f]))) 133 | (define (terminate reason state) 134 | (ws:close ($state ws))) 135 | (define (handle-call msg from state) 136 | (match msg 137 | [#(call ,msg) 138 | (match (try (do-connect state)) 139 | [`(catch ,reason ,err) 140 | `#(reply ,err ,state)] 141 | [,ws 142 | (let ([id (+ ($state id) 1)]) 143 | (json:set! msg 'id id) 144 | (ws:send ws (json:object->bytevector msg)) 145 | `#(no-reply 146 | ,($state copy 147 | [ws ws] 148 | [id id] 149 | [id-map (ht:set ($state id-map) id from)])))])])) 150 | (define (handle-cast msg state) 151 | (match msg 152 | [#(cast ,msg) 153 | (match (try (do-connect state)) 154 | [`(catch ,_) 155 | `#(no-reply ,state)] 156 | [,ws 157 | (ws:send ws (json:object->bytevector msg)) 158 | `#(no-reply ,($state copy [ws ws]))])])) 159 | (define (handle-info msg state) 160 | (match msg 161 | [#(ws:message ,ws ,message) 162 | (let ([msg (if (string? message) 163 | (json:string->object message) 164 | (json:bytevector->object message))]) 165 | (match (json:ref msg 'id #f) 166 | [#f 167 | (match (json:ref msg 'method #f) 168 | ["synchronize" 169 | `#(no-reply 170 | ,($state copy 171 | [sync-token (json:ref msg '(params sync-token) #f)]))] 172 | [,_ 173 | (fprintf (console-error-port) "Unhandled Tower event\n") 174 | (json:write (console-error-port) msg 0) 175 | (newline (console-error-port)) 176 | (flush-output-port (console-error-port)) 177 | `#(no-reply ,state)])] 178 | [,id 179 | (match (ht:ref ($state id-map) id #f) 180 | [#f 181 | (fprintf (console-error-port) "Unexpected message\n") 182 | (json:write (console-error-port) msg 0) 183 | (newline (console-error-port)) 184 | (flush-output-port (console-error-port)) 185 | `#(no-reply ,state)] 186 | [,from 187 | (let ([reply (rpc-reply msg)] 188 | [state ($state copy 189 | [id-map (ht:delete ($state id-map) id)])]) 190 | (gen-server:reply from reply) 191 | `#(no-reply ,state))])]))] 192 | [#(ws:closed ,ws ,code ,reason) 193 | `#(no-reply 194 | ,(cond 195 | [(eq? ws ($state ws)) 196 | (ht:fold ($state id-map) 197 | (lambda (k v acc) 198 | (gen-server:reply v (make-fault 'disconnected)) 199 | acc) 200 | (void)) 201 | ($state copy 202 | [ws #f] 203 | [id 0] 204 | [id-map (ht:make values eq? fixnum?)])] 205 | [else state]))] 206 | [#(ws:init ,ws) 207 | `#(no-reply ,state)])) 208 | (gen-server:start&link 'tower-client)) 209 | 210 | (define (tower-client:call msg) 211 | (gen-server:call 'tower-client `#(call ,msg))) 212 | 213 | (define (tower-client:cast msg) 214 | (gen-server:cast 'tower-client `#(cast ,msg))) 215 | 216 | (define (tower-client:get-completions filename line char prefix) 217 | (tower-client:call 218 | (json:make-object 219 | [method "get-completions"] 220 | [params 221 | (json:make-object 222 | [filename filename] 223 | [line line] 224 | [char char] 225 | [prefix prefix])]))) 226 | 227 | (define (tower-client:get-definitions filename name) 228 | (tower-client:call 229 | (json:make-object 230 | [method "get-definitions"] 231 | [params 232 | (json:make-object 233 | [filename filename] 234 | [name name])]))) 235 | 236 | (define (tower-client:get-references filename name) 237 | (tower-client:call 238 | (json:make-object 239 | [method "get-references"] 240 | [params 241 | (json:make-object 242 | [filename filename] 243 | [name name])]))) 244 | 245 | (define (tower-client:get-local-references filename name) 246 | (tower-client:call 247 | (json:make-object 248 | [method "get-local-references"] 249 | [params 250 | (json:make-object 251 | [filename filename] 252 | [name name])]))) 253 | 254 | (define (tower-client:log msg) 255 | (tower-client:cast 256 | (json:make-object 257 | [method "log"] 258 | [params 259 | (json:make-object 260 | [timestamp (erlang:now)] 261 | [message msg])]))) 262 | 263 | (define (tower-client:reset-directory dir) 264 | (tower-client:call 265 | (json:make-object 266 | [method "reset-directory"] 267 | [params 268 | (json:make-object 269 | [directory dir])]))) 270 | 271 | (define (tower-client:update-keywords keywords) 272 | ;; Keywords is a list of JSON objects containing: keyword, meta 273 | (tower-client:call 274 | (json:make-object 275 | [method "update-keywords"] 276 | [params 277 | (json:make-object 278 | [keywords keywords])]))) 279 | 280 | (define (tower-client:update-references filename refs) 281 | ;; Refs is a list of JSON objects containing: name, line, char, meta 282 | (tower-client:call 283 | (json:make-object 284 | [method "update-references"] 285 | [params 286 | (json:make-object 287 | [filename filename] 288 | [references refs])]))) 289 | 290 | (define (tower-client:shutdown-server) 291 | (tower-client:call 292 | (json:make-object 293 | [method "shutdown"] 294 | [params (json:make-object)]))) 295 | ) 296 | -------------------------------------------------------------------------------- /tower.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2020 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | #!chezscheme 24 | (library (tower) 25 | (export 26 | tower:running? 27 | tower:start-server 28 | tower:sup-spec 29 | ) 30 | (import 31 | (chezscheme) 32 | (json) 33 | (keywords) 34 | (software-info) 35 | (swish imports) 36 | ) 37 | 38 | (define verbosity (make-parameter 0)) 39 | 40 | (define (mapn f ls) 41 | (let lp ([i 0] [ls ls]) 42 | (if (null? ls) 43 | '() 44 | (cons (f i (car ls)) 45 | (lp (+ i 1) (cdr ls)))))) 46 | 47 | (define (rpc:respond ws req result) 48 | (let ([res (json:make-object [jsonrpc "2.0"])] 49 | [id (json:ref req 'id #f)]) 50 | (when id 51 | (json:extend-object res [id id])) 52 | (when result 53 | (json:extend-object res [result result])) 54 | (ws:send ws (json:object->string res)))) 55 | 56 | (define (send-sync-event ws dir key) 57 | (ws:send ws 58 | (json:object->bytevector 59 | (json:make-object 60 | [method "synchronize"] 61 | [params 62 | (json:make-object 63 | [sync-token 64 | (json:make-object 65 | [dir dir] 66 | [key key])])])))) 67 | 68 | (define (scalar x) 69 | (match x 70 | [(#(,v)) v] 71 | [() #f])) 72 | 73 | (define ($update-keywords timestamp keywords) 74 | (db:log 'log-db "delete from keywords") 75 | (for-each 76 | (lambda (kw) 77 | (db:log 'log-db "insert into keywords(timestamp,keyword,meta) values(?,?,?)" 78 | (coerce timestamp) 79 | (coerce (json:get kw 'keyword)) 80 | (coerce (json:get kw 'meta)))) 81 | keywords)) 82 | 83 | (define (maybe-rows rows) 84 | (and (not (null? rows)) rows)) 85 | 86 | (define ($defns-in-file name filename) 87 | (maybe-rows 88 | (execute " 89 | select F.filename,D.line,D.char from refs D 90 | inner join files F on F.file_pk=D.file_fk 91 | where D.name=? 92 | and F.filename=? 93 | and D.type='defn' 94 | order by D.line asc" 95 | name filename))) 96 | 97 | (define ($defns-in-workspace name root-fk) 98 | (maybe-rows 99 | (execute " 100 | select F.filename,D.line,D.char from refs D 101 | inner join files F on F.file_pk=D.file_fk 102 | where D.name=? 103 | and D.root_fk=? 104 | and D.type='defn' 105 | order by substr(F.filename,-3)='.ss' desc, F.filename asc, D.line asc" 106 | name root-fk))) 107 | 108 | (define ($refs-in-file name filename) 109 | (execute " 110 | select D.line,D.char from refs D 111 | inner join files F on F.file_pk=D.file_fk 112 | where D.name=? 113 | and F.filename=? 114 | order by D.line asc" 115 | name filename)) 116 | 117 | (define ($refs-in-workspace name root-fk) 118 | (execute " 119 | select F.filename,D.line,D.char from refs D 120 | inner join files F on F.file_pk=D.file_fk 121 | where D.name=? 122 | and D.root_fk=? 123 | order by substr(F.filename,-3)='.ss' desc, F.filename asc, D.line asc" 124 | name root-fk)) 125 | 126 | (define ($defns-anywhere name filename) 127 | (maybe-rows 128 | (execute " 129 | select F.filename,D.line,D.char from refs D 130 | inner join roots R on D.root_fk=R.root_pk 131 | inner join files F on F.file_pk=D.file_fk 132 | where D.name=? 133 | and D.type='defn' 134 | order by F.filename=? desc, R.timestamp desc, 135 | substr(F.filename,-3)='.ss' desc, F.filename asc, D.line asc" 136 | name filename))) 137 | 138 | (define do-log 139 | (case-lambda 140 | [(level message) 141 | (do-log level (erlang:now) message)] 142 | [(level timestamp message) 143 | (db:log 'log-db 144 | "insert into events(timestamp,pid,message) values(?,?,?)" 145 | (coerce timestamp) 146 | (coerce self) 147 | (coerce message)) 148 | (cond 149 | [(< (verbosity) level) (void)] 150 | [(json:object? message) 151 | (json:write (current-output-port) message 0)] 152 | [else 153 | (display message) 154 | (newline)])])) 155 | 156 | (define (prefix-integer s) 157 | (if (string=? s "") 158 | 0 159 | (char->integer (char-downcase (string-ref s 0))))) 160 | 161 | (define (handle-message ws msg) 162 | (match (string->symbol (json:get msg 'method)) 163 | [log 164 | (do-log 2 165 | (or (json:ref msg '(params timestamp) #f) (erlang:now)) 166 | (json:get msg '(params message)))] 167 | [get-completions 168 | (let* ([filename (json:get msg '(params filename))] 169 | [line (json:get msg '(params line))] 170 | [char (json:get msg '(params char))] 171 | [prefix (json:get msg '(params prefix))] 172 | ;; when the identifier contains with a percent or 173 | ;; underscore, we need to escape it using an uncommon 174 | ;; character, like #\esc 175 | [pat (string-append (pregexp-replace* "([_%])" prefix "\x1B;\\1") "%")] 176 | [root-fk (root-key)] 177 | [start (erlang:now)] 178 | [rows 179 | (transaction 'log-db 180 | (let ([file-fk (scalar (execute "select file_pk from files where filename=?" filename))] 181 | [pre1 (prefix-integer prefix)]) 182 | (execute " 183 | select 184 | case when file_fk=?4 then sum(?5 - min(0, line)) else 0 end as rank 185 | ,count(refs.name) as count 186 | ,candidates.name 187 | from 188 | (select keyword as name from keywords where keyword like ?2 escape '\x1B;' 189 | union 190 | select name from refs 191 | where pre1=?1 and name like ?2 escape '\x1B;' and root_fk=?3 192 | ) candidates 193 | left outer join refs 194 | on candidates.name = refs.name 195 | group by candidates.name 196 | order by rank desc, count desc, candidates.name asc" 197 | pre1 pat root-fk file-fk line)))] 198 | [rows 199 | (match rows 200 | [(#(,_ 1 ,@prefix) . ,rest) rest] 201 | [,_ rows])] 202 | [nrows (length rows)] 203 | [completions 204 | (mapn 205 | (lambda (i row) 206 | (match row 207 | [#(,rank ,count ,name) 208 | (let ([sortText (format "~6d" i)] 209 | [score (- 1.0 (/ i nrows))]) 210 | (json:make-object 211 | [label name] 212 | ;;[detail (format "| rank:~a | count:~a | sort: ~a | score: ~a" rank count sortText score)] 213 | [sortText sortText] 214 | [score score]))])) 215 | rows)] 216 | [end (erlang:now)] 217 | [log (json:make-object 218 | [_op_ "get-completions"] 219 | [filename filename] 220 | [line line] 221 | [char char] 222 | [prefix prefix] 223 | [found (length completions)] 224 | [time (- end start)])]) 225 | (do-log 1 log) 226 | (rpc:respond ws msg completions))] 227 | [get-definitions 228 | (let* ([filename (json:get msg '(params filename))] 229 | [name (json:get msg '(params name))] 230 | [root-fk (root-key)] 231 | [start (erlang:now)] 232 | [defns 233 | (map 234 | (lambda (row) 235 | (match row 236 | [#(,fn ,line ,char) 237 | (json:make-object 238 | [filename fn] 239 | [line line] 240 | [char char])])) 241 | (transaction 'log-db 242 | (or ($defns-in-file name filename) 243 | ($defns-in-workspace name root-fk) 244 | ($defns-anywhere name filename) 245 | '())))] 246 | [end (erlang:now)] 247 | [log (json:make-object 248 | [_op_ "get-definitions"] 249 | [filename filename] 250 | [name name] 251 | [found (length defns)] 252 | [time (- end start)])]) 253 | (do-log 1 log) 254 | (rpc:respond ws msg defns))] 255 | [get-local-references 256 | (let* ([filename (json:get msg '(params filename))] 257 | [name (json:get msg '(params name))] 258 | [start (erlang:now)] 259 | [refs 260 | (map 261 | (lambda (row) 262 | (match row 263 | [#(,line ,char) 264 | (json:make-object 265 | [line line] 266 | [char char])])) 267 | (transaction 'log-db 268 | ($refs-in-file name filename)))] 269 | [end (erlang:now)] 270 | [log (json:make-object 271 | [_op_ "get-local-references"] 272 | [filename filename] 273 | [name name] 274 | [found (length refs)] 275 | [time (- end start)])]) 276 | (do-log 1 log) 277 | (rpc:respond ws msg refs))] 278 | [get-references 279 | (let* ([filename (json:get msg '(params filename))] 280 | [name (json:get msg '(params name))] 281 | [root-fk (root-key)] 282 | [start (erlang:now)] 283 | [refs 284 | (map 285 | (lambda (row) 286 | (match row 287 | [#(,fn ,line ,char) 288 | (json:make-object 289 | [filename fn] 290 | [line line] 291 | [char char])])) 292 | (transaction 'log-db 293 | ($refs-in-workspace name root-fk)))] 294 | [end (erlang:now)] 295 | [log (json:make-object 296 | [_op_ "get-references"] 297 | [filename filename] 298 | [name name] 299 | [found (length refs)] 300 | [time (- end start)])]) 301 | (do-log 1 log) 302 | (rpc:respond ws msg refs))] 303 | [reset-directory 304 | (let* ([dir (json:get msg '(params directory))] 305 | [pk 306 | (transaction 'log-db 307 | (match (scalar (execute "select root_pk from roots where path=?" dir)) 308 | [#f 309 | (execute "insert into roots(timestamp,path,meta) values(?,?,?)" 310 | (coerce (erlang:now)) 311 | (coerce dir) 312 | (coerce (json:make-object))) 313 | (scalar (execute "select last_insert_rowid()"))] 314 | [,pk 315 | (execute "update roots set timestamp=?, meta=json_patch(meta,?) where path=?" 316 | (coerce (erlang:now)) 317 | (coerce (json:make-object)) 318 | dir) 319 | (execute "delete from refs where root_fk=? or root_fk is null" pk) 320 | pk]))]) 321 | (root-dir dir) 322 | (root-key pk) 323 | (send-sync-event ws dir pk) 324 | (rpc:respond ws msg "ok"))] 325 | [synchronize 326 | (let ([dir (json:get msg '(params sync-token dir))] 327 | [key (json:get msg '(params sync-token key))]) 328 | (assert (not (root-dir))) 329 | (assert (not (root-key))) 330 | (root-dir dir) 331 | (root-key key) 332 | (do-log 1 333 | (json:make-object 334 | [_op_ "synchronize"] 335 | [root-dir dir] 336 | [root-key key])))] 337 | [update-keywords 338 | (let ([keywords (json:get msg '(params keywords))] 339 | [start (erlang:now)]) 340 | ($update-keywords start keywords) 341 | (unless (< (verbosity) 1) 342 | (transaction 'log-db 343 | (do-log 1 344 | (json:make-object 345 | [_op_ "update-keywords"] 346 | [keywords (scalar (execute "select count(*) from keywords"))] 347 | [time (- (erlang:now) start)])))) 348 | (rpc:respond ws msg "ok"))] 349 | [update-references 350 | (let ([filename (json:get msg '(params filename))] 351 | [refs (json:get msg '(params references))] 352 | [root-fk (root-key)] 353 | [start (erlang:now)]) 354 | (assert (path-absolute? filename)) 355 | (db:log 'log-db "insert into files (timestamp,filename) values (?,?) on conflict(filename) do update set timestamp=excluded.timestamp" 356 | (coerce start) 357 | (coerce filename)) 358 | (let ([file-fk (transaction 'log-db 359 | (scalar (execute "select file_pk from files where filename=?" filename)))]) 360 | (db:log 'log-db "delete from refs where file_fk=?" file-fk) 361 | (for-each 362 | (lambda (ref) 363 | (let ([meta (json:get ref 'meta)] 364 | [name (json:get ref 'name)]) 365 | (db:log 'log-db "insert into refs(timestamp,root_fk,file_fk,pre1,name,type,line,char,meta) values(?,?,?,?,?,?,?,?,?)" 366 | (coerce start) 367 | (coerce root-fk) 368 | (coerce file-fk) 369 | (coerce (prefix-integer name)) 370 | (coerce name) 371 | (coerce (and (= (json:ref meta 'definition 0) 1) 372 | "defn")) 373 | (coerce (json:get ref 'line)) 374 | (coerce (json:get ref 'char)) 375 | (coerce meta)))) 376 | refs)) 377 | (unless (< (verbosity) 1) 378 | (transaction 'log-db 379 | (do-log 1 380 | (json:make-object 381 | [_op_ "update-references"] 382 | [filename filename] 383 | [definitions (scalar (execute "select count(*) from refs where type='defn'"))] 384 | [references (scalar (execute "select count(*) from refs"))] 385 | [time (- (erlang:now) start)])))) 386 | (rpc:respond ws msg "ok"))] 387 | [shutdown 388 | (do-log 1 (json:make-object [_op_ "shutdown"])) 389 | (rpc:respond ws msg "ok") 390 | (app:shutdown)] 391 | )) 392 | 393 | (define root-dir (make-process-parameter #f)) 394 | (define root-key (make-process-parameter #f)) 395 | 396 | (define (client) 397 | (ui:register) 398 | (let lp () 399 | (receive 400 | [#(ws:message ,ws ,msg) 401 | (match (try 402 | (handle-message ws 403 | (if (string? msg) 404 | (json:string->object msg) 405 | (json:bytevector->object msg)))) 406 | [`(catch ,reason ,e) 407 | (do-log 1 (exit-reason->english reason)) 408 | (throw e)] 409 | [,_ (lp)])] 410 | [#(ws:closed ,ws ,code ,reason) 'ok] 411 | [#(ws:init ,ws) (lp)]))) 412 | 413 | (define (ui:start&link) 414 | (define-state-tuple waketime clients) 415 | 416 | (define (reply x state) 417 | `#(reply ,x ,state ,($state waketime))) 418 | (define (no-reply state) 419 | `#(no-reply ,state ,($state waketime))) 420 | 421 | (define (init) `#(ok ,( make [waketime 'infinity] [clients '()]))) 422 | (define (terminate reason state) 'ok) 423 | (define (handle-call msg from state) 424 | (match msg 425 | [#(register ,pid) 426 | (monitor pid) 427 | (let ([clients (cons pid ($state clients))]) 428 | (do-log 1 429 | (json:make-object 430 | [_op_ "connected"] 431 | [pid (coerce pid)] 432 | [total-clients (length clients)])) 433 | (reply 'ok ($state copy [waketime 'infinity] [clients clients])))] 434 | [num-clients 435 | (reply (length ($state clients)) state)] 436 | [shutdown-time 437 | (let ([waketime ($state waketime)]) 438 | (reply (and (fixnum? waketime) waketime) state))])) 439 | (define (handle-cast msg state) (match msg)) 440 | (define (handle-info msg state) 441 | (match msg 442 | [`(DOWN ,_ ,pid ,_) 443 | (let ([clients (remq pid ($state clients))]) 444 | (do-log 1 445 | (json:make-object 446 | [_op_ "disconnected"] 447 | [pid (coerce pid)] 448 | [total-clients (length clients)])) 449 | (no-reply ($state copy 450 | [clients clients] 451 | [waketime 452 | (if (null? clients) 453 | (+ (erlang:now) 30000) 454 | 'infinity)])))] 455 | [timeout 456 | (app:shutdown) 457 | `#(no-reply ,state)])) 458 | (gen-server:start&link 'ui)) 459 | 460 | (define (ui:register) 461 | (gen-server:call 'ui `#(register ,self))) 462 | 463 | (define (ui:num-clients) 464 | (gen-server:call 'ui 'num-clients)) 465 | 466 | (define (ui:shutdown-time) 467 | (gen-server:call 'ui 'shutdown-time)) 468 | 469 | (define (tower:running? port-number) 470 | (match (try 471 | (let-values ([(ip op) (connect-tcp "localhost" port-number)]) 472 | (close-port op))) 473 | [`(catch ,reason) #f] 474 | [,_ #t])) 475 | 476 | (define (tower-db:setup) 477 | (define schema-name 'swish-lint) 478 | (define schema-version "2020-05-22") 479 | (define (init-db) 480 | (define (create-index name sql) 481 | (execute (format "create index if not exists ~a on ~a" name sql))) 482 | 483 | (create-table events 484 | [timestamp integer] 485 | [pid text] 486 | [message text]) 487 | (create-table files 488 | [file_pk integer primary key] 489 | [timestamp integer] 490 | [filename text unique]) 491 | (create-table keywords 492 | [timestamp integer] 493 | [keyword text] 494 | [meta text]) 495 | (create-table refs 496 | [timestamp integer] 497 | [root_fk integer] 498 | [file_fk integer] 499 | [pre1 integer] 500 | [name text] 501 | [type text] 502 | [line integer] 503 | [char integer] 504 | [meta text]) 505 | (create-table roots 506 | [root_pk integer primary key] 507 | [timestamp integer] 508 | [path text] 509 | [meta text]) 510 | 511 | (create-prune-on-insert-trigger 'events 'timestamp 1 10) 512 | (create-index 'events_timestamp "events(timestamp)") 513 | 514 | (create-index 'refs_name "refs(name)") 515 | (create-index 'refs_root "refs(root_fk)") 516 | (create-index 'refs_file "refs(file_fk)") 517 | (create-index 'refs_pre1 "refs(pre1)") 518 | (create-index 'refs_type "refs(type)")) 519 | (define (upgrade-db) 520 | (match (log-db:version schema-name) 521 | [,@schema-version 'ok] 522 | [#f 523 | (log-db:version schema-name schema-version) 524 | 'ok] 525 | [,version (throw `#(unsupported-db-version ,schema-name ,version))])) 526 | 527 | (match (db:transaction 'log-db 528 | (lambda () 529 | (upgrade-db) 530 | (init-db))) 531 | [#(ok ,_) 532 | (let ([keywords 533 | (get-keywords 534 | (lambda (reason) 535 | (do-log 1 536 | (json:make-object 537 | [_op_ "get-keywords"] 538 | [error (exit-reason->english reason)]))))]) 539 | ($update-keywords (erlang:now) keywords)) 540 | (db:expire-cache 'log-db) 541 | 'ignore] 542 | [,error error])) 543 | 544 | (define (tower:sup-spec port-number) 545 | `(#(tower-db:setup ,tower-db:setup temporary 1000 worker) 546 | #(ui ,ui:start&link permanent 1000 worker) 547 | ,@(http:configure-server 'http port-number 548 | (http:url-handler 549 | (match ( path request) 550 | ["/" 551 | (let* ([num-clients (ui:num-clients)] 552 | [shutdown-time (and (zero? num-clients) (ui:shutdown-time))] 553 | [limit (http:find-param "limit" params)] 554 | [limit (and limit (string->number limit))] 555 | [limit (or limit 20)]) 556 | (match (transaction 'log-db 557 | (list 558 | (scalar (execute "select count(*) from keywords")) 559 | (scalar (execute "select count(*) from refs where type='defn'")) 560 | (scalar (execute "select count(*) from refs")) 561 | (scalar (execute "select count(*) from files")) 562 | (execute "select datetime(timestamp/1000,'unixepoch','localtime'),path from roots order by timestamp desc") 563 | (execute "select datetime(timestamp/1000,'unixepoch','localtime'),pid,message from events order by rowid desc limit ?" limit))) 564 | [(,keywords ,defns ,refs ,files ,roots ,log) 565 | (http:respond conn 200 '(("Content-Type" . "text/html")) 566 | (html->bytevector 567 | `(html5 568 | (head 569 | (meta (@ (charset "UTF-8"))) 570 | (title ,(software-product-name))) 571 | (body 572 | (pre 573 | ,(when shutdown-time 574 | (format "Shut down in ~a seconds\n\n" 575 | (exact (ceiling (/ (- shutdown-time (erlang:now)) 1000.0))))) 576 | ,(format "Connected clients: ~9:D\n" num-clients) 577 | ,(format " Keywords: ~9:D\n" keywords) 578 | ,(format " Definitions: ~9:D\n" defns) 579 | ,(format " References: ~9:D\n" refs) 580 | ,(format " Unique files: ~9:D\n" files)) 581 | (pre 582 | ,@(map 583 | (lambda (root) 584 | (match root 585 | [#(,date ,path) 586 | (format "~a ~a\n" date path)])) 587 | roots)) 588 | (pre 589 | ,@(map 590 | (lambda (row) 591 | (match row 592 | [#(,date ,pid ,message) 593 | (format "~a ~a ~a\n" date pid message)])) 594 | log)) 595 | (hr) 596 | (pre ,(versions->string))))))]))] 597 | ["/tower" 598 | (ws:upgrade conn request (spawn&link client))] 599 | [,_ #f]))))) 600 | 601 | (define (tower:start-server verbose tower-db port-number) 602 | (verbosity (or verbose 0)) 603 | (log-file 604 | (cond 605 | [(not tower-db) ":memory:"] 606 | [(path-absolute? tower-db) tower-db] 607 | [else (path-combine (base-dir) tower-db)])) 608 | (app-sup-spec (append (app-sup-spec) (tower:sup-spec port-number))) 609 | (app:start) 610 | (receive)) 611 | ) 612 | -------------------------------------------------------------------------------- /trace.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright 2022 Beckman Coulter, Inc. 2 | ;;; 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation 5 | ;;; files (the "Software"), to deal in the Software without 6 | ;;; restriction, including without limitation the rights to use, copy, 7 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 | ;;; of the Software, and to permit persons to whom the Software is 9 | ;;; furnished to do so, subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | ;;; DEALINGS IN THE SOFTWARE. 22 | 23 | (library (trace) 24 | (export 25 | trace-expr 26 | trace-init 27 | trace-msg 28 | trace-time 29 | trace? 30 | ) 31 | (import 32 | (chezscheme) 33 | (json) 34 | (swish imports) 35 | ) 36 | (define trace? (equal? (getenv "SWISH_LINT_TRACE") "yes")) 37 | 38 | (define (trace-init) 39 | (trace-output-port (console-error-port))) 40 | 41 | (define (trace-expr expr) 42 | (when trace? 43 | (pretty-print expr (trace-output-port)) 44 | (flush-output-port (trace-output-port))) 45 | expr) 46 | 47 | (define (trace-msg msg) 48 | (when trace? 49 | (json:write-flat (trace-output-port) msg) 50 | (newline (trace-output-port)) 51 | (flush-output-port (trace-output-port))) 52 | msg) 53 | 54 | (define-syntax trace-time 55 | (syntax-rules () 56 | [(_ $who e1 e2 ...) 57 | (let ([f (lambda () e1 e2 ...)]) 58 | (if (not trace?) 59 | (f) 60 | (let ([who $who] 61 | [start (erlang:now)]) 62 | (call-with-values 63 | f 64 | (lambda result 65 | (let* ([end (erlang:now)] 66 | [dur (- end start)]) 67 | (when (> dur 20) 68 | (pretty-print `(time ,who ,dur ms) 69 | (trace-output-port)) 70 | (newline (trace-output-port)) 71 | (flush-output-port (trace-output-port)))) 72 | (apply values result))))))])) 73 | ) 74 | --------------------------------------------------------------------------------