From 2dc944a8c5285efecfe94ced24f21c5a8d3f39b9 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Wed, 22 Apr 2026 19:47:38 +0800 Subject: [PATCH 01/17] Normalize tokens' types in lexer Imported racket-lexer does not return a good meaningful type for some tokens, so add a extra pass to normalize them. --- doclib/lexer.rkt | 37 +++++++++++++++++++++---- tests/lib/lexer-test.rkt | 58 ++++++++++++++++++++++++++++++++++++---- 2 files changed, 85 insertions(+), 10 deletions(-) diff --git a/doclib/lexer.rkt b/doclib/lexer.rkt index 6207c56..5e37bf8 100644 --- a/doclib/lexer.rkt +++ b/doclib/lexer.rkt @@ -33,6 +33,12 @@ ;; that language's `color-lexer`; when a colorer reports an attribute hash it ;; extracts the `'type` field. ;; +;; This module normalizes token kinds so callers see stable shapes across +;; valid and invalid inputs: +;; - 'lang-directive: a leading `#lang` +;; - 'reader-directive: a leading `#reader` +;; - quote-family prefixes and `#;` +;; ;; This module caches the full lexer stream so callers can distinguish any ;; token class at a given position while reconstructing public token strings on ;; demand. @@ -54,12 +60,28 @@ (define (normalize-lexer-pos pos) (max 0 (sub1 pos))) +(define (make-lexer-span start end type) + (and (< start end) + (LexerTokenSpan start end type))) + ;; Record one lexer span from the lexer stream. (define (record-lexer-entry type start end) (define normalized-start (normalize-lexer-pos start)) (define normalized-end (normalize-lexer-pos end)) - (and (< normalized-start normalized-end) - (LexerTokenSpan normalized-start normalized-end type))) + (make-lexer-span normalized-start normalized-end type)) + +(define (normalize-token type text) + (match* (type text) + [((or 'other 'error) (regexp #px"^#lang(?:\\s|$)")) + 'lang-directive] + [(_ (regexp #px"^#reader(?:\\s|$)")) + 'reader-directive] + [(_ "'") 'quote] + [(_ "`") 'quasiquote] + [(_ ",") 'unquote] + [(_ ",@") 'unquote-splicing] + [(_ "#;") 'sexp-comment] + [(_ _) type])) (define (lexer-span->public snapshot span) (LexerEntry (LexerTokenSpan-start span) @@ -231,16 +253,21 @@ ;; the language-specific lexer selected above. (define initial-span (and (not (eof-object? initial-txt)) - (record-lexer-entry initial-type initial-start initial-end))) + (record-lexer-entry (normalize-token initial-type initial-txt) + initial-start + initial-end))) (define token-spans (append (if initial-span (list initial-span) '()) (for*/list ([lst (in-port (lexer-wrap lexer) in)] [span (in-value (match lst - [(list _txt type _paren? start end) - (record-lexer-entry type start end)]))] + [(list txt type _paren? start end) + (record-lexer-entry (normalize-token type txt) + start + end)]))] #:when span) span))) + (LexerSnapshot text (list->vector token-spans))) (define/contract (lexer-snapshot-token-at snapshot pos) diff --git a/tests/lib/lexer-test.rkt b/tests/lib/lexer-test.rkt index fbd2214..4823d0f 100644 --- a/tests/lib/lexer-test.rkt +++ b/tests/lib/lexer-test.rkt @@ -6,15 +6,20 @@ "../../doclib/lexer.rkt" "../../common/interfaces.rkt") + (define (entry-summary entry) + (list (LexerEntry-start entry) + (LexerEntry-end entry) + (LexerEntry-text entry) + (LexerEntry-type entry))) + + (define (snapshot-summaries text) + (for/list ([entry (in-lexer-snapshot (build-lexer-snapshot text))]) + (entry-summary entry))) + (test-case "build-lexer-snapshot enumerates public lexer entries" (define snapshot (build-lexer-snapshot "#lang racket\n(define x 1)\n")) (define entries (for/list ([entry (in-lexer-snapshot snapshot)]) entry)) - (define (entry-summary entry) - (list (LexerEntry-start entry) - (LexerEntry-end entry) - (LexerEntry-text entry) - (LexerEntry-type entry))) ;; Cached lexer positions are normalized to the doc's 0-based offsets. (check-not-false (member (list 13 14 "(" 'parenthesis) (map entry-summary entries))) @@ -29,6 +34,49 @@ (check-not-false (member (list 24 25 ")" 'parenthesis) (map entry-summary entries)))) + (test-case + "lexer snapshot normalizes a leading #lang directive" + (check-equal? + (take (snapshot-summaries "#lang racket/base\n(define x 1)\n") 2) + (list (list 0 17 "#lang racket/base" 'lang-directive) + (list 17 18 "\n" 'white-space)))) + + (test-case + "lexer snapshot keeps an invalid #lang payload in the same normalized shape" + (check-equal? + (take (snapshot-summaries "#lang not-a-real-language\n(define x 1)\n") 2) + (list (list 0 25 "#lang not-a-real-language" 'lang-directive) + (list 25 26 "\n" 'white-space)))) + + (test-case + "lexer snapshot normalizes #lang reader without collapsing the payload" + (check-equal? + (take (snapshot-summaries "#lang reader syntax/module-reader\nracket/base\n") 2) + (list (list 0 33 "#lang reader syntax/module-reader" 'lang-directive) + (list 33 34 "\n" 'white-space)))) + + (test-case + "lexer snapshot keeps a leading #reader token as one big token" + (check-equal? + (take (snapshot-summaries "#reader scribble/reader\n@title{demo}\n") 2) + (list (list 0 7 "#reader" 'reader-directive) + (list 7 8 " " 'white-space)))) + + (test-case + "lexer snapshot normalizes quote-family prefixes" + (define prefix-entries + (filter (lambda (summary) + (not (string=? (list-ref summary 2) " "))) + (snapshot-summaries "' ` , ,@ #; x"))) + (check-equal? + prefix-entries + (list (list 0 1 "'" 'quote) + (list 2 3 "`" 'quasiquote) + (list 4 5 "," 'unquote) + (list 6 8 ",@" 'unquote-splicing) + (list 9 11 "#;" 'sexp-comment) + (list 12 13 "x" 'symbol)))) + (test-case "lexer snapshot position queries return token and symbol entries" (define snapshot From e699e65361e3b035ed82bb13b932cb116cce878b Mon Sep 17 00:00:00 2001 From: 6cdh Date: Thu, 23 Apr 2026 15:05:28 +0800 Subject: [PATCH 02/17] Add a simple token tree parser --- doclib/lexer.rkt | 96 +++++++++++++++---------------------- doclib/lexer/shared.rkt | 47 ++++++++++++++++++ doclib/lexer/token-tree.rkt | 91 +++++++++++++++++++++++++++++++++++ tests/lib/doc-test.rkt | 14 ++---- tests/lib/lexer-test.rkt | 62 ++++++++++++++++++++++-- 5 files changed, 239 insertions(+), 71 deletions(-) create mode 100644 doclib/lexer/shared.rkt create mode 100644 doclib/lexer/token-tree.rkt diff --git a/doclib/lexer.rkt b/doclib/lexer.rkt index 5e37bf8..9419696 100644 --- a/doclib/lexer.rkt +++ b/doclib/lexer.rkt @@ -1,6 +1,8 @@ #lang racket/base (require "../common/interfaces.rkt" + "lexer/shared.rkt" + "lexer/token-tree.rkt" racket/contract racket/match syntax-color/module-lexer @@ -37,19 +39,13 @@ ;; valid and invalid inputs: ;; - 'lang-directive: a leading `#lang` ;; - 'reader-directive: a leading `#reader` -;; - quote-family prefixes and `#;` +;; - quote-family and syntax quote-family prefixes, plus `#;` +;; - open-paren/close-paren direction for the internal span cache ;; ;; This module caches the full lexer stream so callers can distinguish any ;; token class at a given position while reconstructing public token strings on ;; demand. -;; Cached lexer output for a document. Tokens are stored in source order so -;; point lookups can binary-search by span start while reconstructing public -;; token strings on demand. -(struct LexerTokenSpan - (start end type) - #:transparent) - (struct/contract LexerSnapshot ([text string?] [tokens (vectorof LexerTokenSpan?)]) @@ -60,30 +56,14 @@ (define (normalize-lexer-pos pos) (max 0 (sub1 pos))) -(define (make-lexer-span start end type) - (and (< start end) - (LexerTokenSpan start end type))) - ;; Record one lexer span from the lexer stream. -(define (record-lexer-entry type start end) +(define (record-lexer-span type start end) (define normalized-start (normalize-lexer-pos start)) (define normalized-end (normalize-lexer-pos end)) (make-lexer-span normalized-start normalized-end type)) -(define (normalize-token type text) - (match* (type text) - [((or 'other 'error) (regexp #px"^#lang(?:\\s|$)")) - 'lang-directive] - [(_ (regexp #px"^#reader(?:\\s|$)")) - 'reader-directive] - [(_ "'") 'quote] - [(_ "`") 'quasiquote] - [(_ ",") 'unquote] - [(_ ",@") 'unquote-splicing] - [(_ "#;") 'sexp-comment] - [(_ _) type])) - -(define (lexer-span->public snapshot span) +(define/contract (lexer-snapshot-span->entry snapshot span) + (-> LexerSnapshot? LexerTokenSpan? LexerEntry?) (LexerEntry (LexerTokenSpan-start span) (LexerTokenSpan-end span) (substring (LexerSnapshot-text snapshot) @@ -114,7 +94,7 @@ (and idx (let ([span (vector-ref tokens idx)]) (and (<= (LexerTokenSpan-start span) pos) - (lexer-span->public snapshot span))))) + (lexer-snapshot-span->entry snapshot span))))) ;; Find the token at `pos`, or the last token before `pos` when `pos` falls ;; between token spans. @@ -133,24 +113,15 @@ (define (lexer-layout-token? type) (memq type '(white-space comment sexp-comment))) -(define (lexer-token-span-paren-kind snapshot span) - (and (eq? (LexerTokenSpan-type span) 'parenthesis) - (case (string-ref (LexerSnapshot-text snapshot) (LexerTokenSpan-start span)) - [(#\() 'open] - [(#\[) 'open] - [(#\)) 'close] - [(#\]) 'close] - [else #f]))) - (define (scan-enclosing-paren snapshot tokens idx depth) (cond [(< idx 0) #f] [else (define span (vector-ref tokens idx)) - (match (lexer-token-span-paren-kind snapshot span) - ['close + (match (LexerTokenSpan-type span) + ['close-paren (scan-enclosing-paren snapshot tokens (sub1 idx) (add1 depth))] - ['open + ['open-paren (if (positive? depth) (scan-enclosing-paren snapshot tokens (sub1 idx) (sub1 depth)) (LexerTokenSpan-start span))] @@ -167,7 +138,8 @@ (cond [(= idx token-count) eof] [else - (define entry (lexer-span->public snapshot (vector-ref tokens idx))) + (define entry + (lexer-snapshot-span->entry snapshot (vector-ref tokens idx))) (set! idx (add1 idx)) entry])) eof))) @@ -199,8 +171,10 @@ [else (define span (vector-ref tokens idx)) (match (LexerTokenSpan-type span) - [(? lexer-layout-token?) (loop (add1 idx))] - ['symbol (LexerTokenSpan-start span)] + [(? lexer-layout-token?) + (loop (add1 idx))] + ['symbol + (LexerTokenSpan-start span)] [_ #f])]))) (define (lexer-wrap lexer) @@ -253,20 +227,21 @@ ;; the language-specific lexer selected above. (define initial-span (and (not (eof-object? initial-txt)) - (record-lexer-entry (normalize-token initial-type initial-txt) - initial-start - initial-end))) + (record-lexer-span (normalize-token initial-type initial-txt) + initial-start + initial-end))) + (define rest-token-spans + (for*/list ([lst (in-port (lexer-wrap lexer) in)] + [span (in-value + (match lst + [(list txt type _paren? start end) + (record-lexer-span (normalize-token type txt) start end)]))] + #:when span) + span)) (define token-spans - (append (if initial-span (list initial-span) '()) - (for*/list ([lst (in-port (lexer-wrap lexer) in)] - [span (in-value - (match lst - [(list txt type _paren? start end) - (record-lexer-entry (normalize-token type txt) - start - end)]))] - #:when span) - span))) + (if initial-span + (cons initial-span rest-token-spans) + rest-token-spans)) (LexerSnapshot text (list->vector token-spans))) @@ -281,8 +256,15 @@ (eq? (LexerEntry-type entry) 'symbol) entry)) -(provide LexerSnapshot? +(provide (struct-out LexerTokenSpan) + LexerSnapshot? + token-node? + sexp-comment-node? + (struct-out Token-Leaf) + (struct-out Token-Tree) + (struct-out Token-Prefix-Tree) build-lexer-snapshot + lexer-snapshot-span->entry in-lexer-snapshot for-each-lexer-snapshot-entry lexer-snapshot-enclosing-paren-start diff --git a/doclib/lexer/shared.rkt b/doclib/lexer/shared.rkt new file mode 100644 index 0000000..8635ca9 --- /dev/null +++ b/doclib/lexer/shared.rkt @@ -0,0 +1,47 @@ +#lang racket/base + +(require racket/contract + racket/match + racket/string) + +(struct/contract LexerTokenSpan + ([start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [type symbol?]) + #:transparent) + +(define (make-lexer-span start end type) + (and (< start end) + (LexerTokenSpan start end type))) + +(define (lang-directive? txt) + (string-prefix? txt "#lang ")) + +(define (normalize-token type text) + (match* (type text) + [('parenthesis (or "(" "[" "{")) + 'open-paren] + [('parenthesis (or ")" "]" "}")) + 'close-paren] + [(_ "'") 'quote] + [(_ "`") 'quasiquote] + [(_ ",") 'unquote] + [(_ "#;") 'sexp-comment] + [(_ "#'") 'syntax-quote] + [(_ "#`") 'syntax-quasiquote] + [(_ "#,@") 'syntax-unquote-splicing] + [(_ "#,") 'syntax-unquote] + [(_ ",@") 'unquote-splicing] + [(_ "#reader") 'reader-directive] + [(_ (? lang-directive?)) 'lang-directive] + [(_ _) type])) + +(define (span-at spans idx) + (and (<= 0 idx) + (< idx (vector-length spans)) + (vector-ref spans idx))) + +(provide (struct-out LexerTokenSpan) + make-lexer-span + normalize-token + span-at) diff --git a/doclib/lexer/token-tree.rkt b/doclib/lexer/token-tree.rkt new file mode 100644 index 0000000..5ef58c4 --- /dev/null +++ b/doclib/lexer/token-tree.rkt @@ -0,0 +1,91 @@ +#lang racket/base + +(require "shared.rkt" + racket/match) + +;; Token-Leaf: a single token span, representing a leaf in the token tree. +(struct Token-Leaf (span) #:transparent) +;; Token-Tree: a delimited form, with an open parenthesis span, +;; a list of child nodes ,and an optional close parenthesis span. +(struct Token-Tree (open-span children close-span) #:transparent) +;; Token-Prefix-Tree: a prefix token (quote-family, syntax quote-family, +;; or `#;`) plus the skippable trivia after it and an +;; optional operand node. +(struct Token-Prefix-Tree (prefix-span skippable-nodes child) #:transparent) + +(define (token-node? value) + (or (Token-Leaf? value) + (Token-Tree? value) + (Token-Prefix-Tree? value))) + +(define (sexp-comment-node? value) + (and (Token-Prefix-Tree? value) + (eq? 'sexp-comment + (LexerTokenSpan-type (Token-Prefix-Tree-prefix-span value))))) + +;; Skip over whitespaces and comments, accumulating them into `nodes` so they can be +;; preserved in the tree if needed. +(define (parse-skippable-node spans idx [nodes '()]) + (define maybe-span (span-at spans idx)) + (match* (maybe-span (and maybe-span (LexerTokenSpan-type maybe-span))) + [(#f #f) + (values (reverse nodes) idx)] + [(span (or 'white-space 'comment)) + (parse-skippable-node spans (add1 idx) (cons (Token-Leaf span) nodes))] + [(_ 'sexp-comment) + (define-values (comment-node comment-idx) + (parse-token-node spans idx)) + (parse-skippable-node spans comment-idx (cons comment-node nodes))] + [(_ _) + (values (reverse nodes) idx)])) + +;; Parse a prefix token and its operand, skipping over any whitespace/comments +;; in between. +(define (parse-prefix-node spans idx prefix-span) + (define-values (skippable-nodes next-idx) + (parse-skippable-node spans (add1 idx))) + (match (span-at spans next-idx) + [#f + (values (Token-Prefix-Tree prefix-span skippable-nodes #f) next-idx)] + [_ + (define-values (child child-idx) + (parse-token-node spans next-idx)) + (values (Token-Prefix-Tree prefix-span skippable-nodes child) child-idx)])) + +;; Parse a list form, recursively parsing its children until the closing parenthesis is found. +(define (parse-list-node spans idx open-span children) + (define maybe-span (span-at spans idx)) + (match* (maybe-span (and maybe-span (LexerTokenSpan-type maybe-span))) + [(#f #f) + (values (Token-Tree open-span (reverse children) #f) idx)] + [(close-span 'close-paren) + (values (Token-Tree open-span (reverse children) close-span) (add1 idx))] + [(_ _) + (define-values (child child-idx) + (parse-token-node spans idx)) + (parse-list-node spans child-idx open-span (cons child children))])) + +(define (parse-token-node spans idx) + (define span (vector-ref spans idx)) + (match (LexerTokenSpan-type span) + [(or 'quote + 'quasiquote + 'unquote + 'unquote-splicing + 'syntax-quote + 'syntax-quasiquote + 'syntax-unquote + 'syntax-unquote-splicing + 'sexp-comment) + (parse-prefix-node spans idx span)] + ['open-paren + (parse-list-node spans (add1 idx) span '())] + [_ + (values (Token-Leaf span) (add1 idx))])) + +(provide token-node? + sexp-comment-node? + parse-token-node + (struct-out Token-Leaf) + (struct-out Token-Tree) + (struct-out Token-Prefix-Tree)) diff --git a/tests/lib/doc-test.rkt b/tests/lib/doc-test.rkt index 2d5caa6..0c60448 100644 --- a/tests/lib/doc-test.rkt +++ b/tests/lib/doc-test.rkt @@ -106,17 +106,9 @@ ;; Inside [ : pos 3 ' '. Previous is [. (check-equal? (doc-find-containing-paren d3 3) 2) - ;; Inside { : pos 5 '}'. - ;; The logic treats { as normal char, so it skips it. - ;; It sees ] at 6 (wait text index: 0:( 1: 2:[ 3: 4:{ 5: 6:] 7: 8:) ) - ;; Let's re-index carefully: - ;; ( [ { ] ) - ;; 012345678 - ;; pos 5 is ' '. Before it is '{' at 4. - ;; It loops back. ] at 6 is AFTER 5. - ;; Loop goes 5->4->3->2. 2 is '['. - ;; So inside { (at 5) it finds [. - (check-equal? (doc-find-containing-paren d3 5) 2) + ;; Inside { : pos 5. The lexer normalizes { as an opening paren, so it is + ;; the enclosing delimiter here. + (check-equal? (doc-find-containing-paren d3 5) 4) ;; Unmatched close (define d4 (make-doc "file:///test.rkt" " ) (")) diff --git a/tests/lib/lexer-test.rkt b/tests/lib/lexer-test.rkt index 4823d0f..27c66bd 100644 --- a/tests/lib/lexer-test.rkt +++ b/tests/lib/lexer-test.rkt @@ -4,6 +4,10 @@ (require rackunit "../../doclib/doc.rkt" "../../doclib/lexer.rkt" + (only-in "../../doclib/lexer/shared.rkt" + make-lexer-span) + (only-in "../../doclib/lexer/token-tree.rkt" + parse-token-node) "../../common/interfaces.rkt") (define (entry-summary entry) @@ -21,7 +25,7 @@ (define snapshot (build-lexer-snapshot "#lang racket\n(define x 1)\n")) (define entries (for/list ([entry (in-lexer-snapshot snapshot)]) entry)) ;; Cached lexer positions are normalized to the doc's 0-based offsets. - (check-not-false (member (list 13 14 "(" 'parenthesis) + (check-not-false (member (list 13 14 "(" 'open-paren) (map entry-summary entries))) (check-not-false (member (list 14 20 "define" 'symbol) (map entry-summary entries))) @@ -31,7 +35,7 @@ (map entry-summary entries))) (check-not-false (member (list 23 24 "1" 'constant) (map entry-summary entries))) - (check-not-false (member (list 24 25 ")" 'parenthesis) + (check-not-false (member (list 24 25 ")" 'close-paren) (map entry-summary entries)))) (test-case @@ -62,6 +66,24 @@ (list (list 0 7 "#reader" 'reader-directive) (list 7 8 " " 'white-space)))) + (test-case + "lexer snapshot keeps a block comment as a comment token" + (check-equal? + (take (snapshot-summaries "#| block |#\n") 2) + (list (list 0 11 "#| block |#" 'comment) + (list 11 12 "\n" 'white-space)))) + + (test-case + "lexer snapshot keeps shebang comments as comment tokens" + (check-equal? + (take (snapshot-summaries "#! /bin/sh\n") 2) + (list (list 0 10 "#! /bin/sh" 'comment) + (list 10 11 "\n" 'white-space))) + (check-equal? + (take (snapshot-summaries "#!/usr/bin/env racket\n") 2) + (list (list 0 21 "#!/usr/bin/env racket" 'comment) + (list 21 22 "\n" 'white-space)))) + (test-case "lexer snapshot normalizes quote-family prefixes" (define prefix-entries @@ -77,6 +99,40 @@ (list 9 11 "#;" 'sexp-comment) (list 12 13 "x" 'symbol)))) + (test-case + "lexer snapshot normalizes syntax quote-family prefixes" + (check-equal? + (filter (lambda (summary) + (not (string=? (list-ref summary 2) " "))) + (snapshot-summaries "#' #` #, #,@ x")) + (list (list 0 2 "#'" 'syntax-quote) + (list 3 5 "#`" 'syntax-quasiquote) + (list 6 8 "#," 'syntax-unquote) + (list 9 12 "#,@" 'syntax-unquote-splicing) + (list 13 14 "x" 'symbol)))) + + (test-case + "token tree parses syntax quote-family prefixes as prefix nodes" + (for ([prefix-type (in-list '(syntax-quote + syntax-quasiquote + syntax-unquote + syntax-unquote-splicing))]) + (define spans + (vector (make-lexer-span 0 2 prefix-type) + (make-lexer-span 2 3 'white-space) + (make-lexer-span 3 4 'symbol))) + (define-values (node next-index) + (parse-token-node spans 0)) + (check-true (Token-Prefix-Tree? node)) + (check-equal? (LexerTokenSpan-type (Token-Prefix-Tree-prefix-span node)) + prefix-type) + (check-equal? + (LexerTokenSpan-type + (Token-Leaf-span (first (Token-Prefix-Tree-skippable-nodes node)))) + 'white-space) + (check-true (Token-Leaf? (Token-Prefix-Tree-child node))) + (check-equal? next-index 3))) + (test-case "lexer snapshot position queries return token and symbol entries" (define snapshot @@ -97,7 +153,7 @@ (LexerEntry-end paren-token) (LexerEntry-text paren-token) (LexerEntry-type paren-token)) - (list 18 19 "(" 'parenthesis)) + (list 18 19 "(" 'open-paren)) (define token (lexer-snapshot-token-at snapshot 36)) (check-true (LexerEntry? token)) From 3a9ab327a1ae13a2905f106529c04863d5686646 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sat, 25 Apr 2026 15:37:26 +0800 Subject: [PATCH 03/17] Add document language detection Add doc-lang module for parseing #lang, #reader, and raw module forms, extract language info, and match against a predefined known language list. Fallback to URI suffix based recognization if not found language header. --- common/path-util.rkt | 4 +- doclib/doc-lang.rkt | 254 ++++++++++++++++++++++++++++++++++++ doclib/lexer.rkt | 1 + doclib/lexer/shared.rkt | 9 +- doclib/lexer/token-tree.rkt | 69 ++++++++++ tests/lib/doc-lang-test.rkt | 177 +++++++++++++++++++++++++ tests/lib/lexer-test.rkt | 67 +++++++++- 7 files changed, 569 insertions(+), 12 deletions(-) create mode 100644 doclib/doc-lang.rkt create mode 100644 tests/lib/doc-lang-test.rkt diff --git a/common/path-util.rkt b/common/path-util.rkt index bb571a1..9174675 100644 --- a/common/path-util.rkt +++ b/common/path-util.rkt @@ -5,15 +5,13 @@ directory-contains?) (require net/url - racket/string racket/list racket/path) (define path->uri (compose url->string path->url)) (define (uri->path uri) - (cond [(string-prefix? uri "file:") (path->string (url->path (string->url uri)))] - [else (uri->path (regexp-replace #rx".*?:" uri "file:"))])) + (path->string (url->path (string->url uri)))) (define (directory-contains? dir filepath) (define dir-parts (explode-path (simple-form-path dir))) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt new file mode 100644 index 0000000..010335d --- /dev/null +++ b/doclib/doc-lang.rkt @@ -0,0 +1,254 @@ +#lang racket/base + +(require "../common/path-util.rkt" + "lexer.rkt" + "lexer/shared.rkt" + "lexer/token-tree.rkt" + racket/contract + racket/list + racket/match + racket/path + racket/string) + +(define language-node-source/c + (or/c + ;; `#lang racket/base` + 'lang-directive + ;; Present `#lang` line with no usable selector. + 'malformed-lang-directive + ;; `#reader scribble/reader` + 'reader-directive + ;; Present `#reader` line with no usable reader. + 'malformed-reader-directive + ;; `#lang reader syntax/module-reader` + 'reader-lang + ;; Present raw `module` form with no language position. + 'malformed-raw-module + ;; `(module name racket/base ...)` + 'raw-module)) + +(struct/contract Language-Node + ([source language-node-source/c] + [text string?] + [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?]) + #:transparent) + +(struct/contract Known-Language + ([name symbol?] + [sexp? boolean?] + [suffixes (listof string?)] + [name-rx regexp?]) + #:transparent) + +(define (Known-Language~kw #:name name + #:sexp? sexp? + #:suffixes suffixes + #:name-rx name-rx) + (Known-Language name sexp? suffixes name-rx)) + +(define known-languages + (list + (Known-Language~kw #:name 'racket + #:sexp? #t + #:suffixes '() + #:name-rx #px"^racket(?:/.*)?$") + (Known-Language~kw #:name 'typed/racket + #:sexp? #t + #:suffixes '() + #:name-rx #px"^typed/racket(?:/.*)?$") + (Known-Language~kw #:name 'scribble + #:sexp? #f + #:suffixes '("scrbl") + #:name-rx #px"^scribble(?:/.*)?$") + (Known-Language~kw #:name 'rhombus + #:sexp? #f + #:suffixes '("rhm") + #:name-rx #px"^rhombus(?:/.*)?$"))) + +(define (source->snapshot source) + (cond + [(LexerSnapshot? source) source] + [(string? source) (build-lexer-snapshot source)])) + +(define (span-text snapshot span) + (substring (LexerSnapshot-text snapshot) + (LexerTokenSpan-start span) + (LexerTokenSpan-end span))) + +(define (token-node-text snapshot node) + (substring (LexerSnapshot-text snapshot) + (token-node-start node) + (token-node-end node))) + +(define (make-language-node source text span) + (Language-Node source + text + (LexerTokenSpan-start span) + (LexerTokenSpan-end span))) + +(define (parse-lang-directive-text text span) + (or (parse-reader-lang-directive-text text span) + (parse-plain-lang-directive-text text span))) + +(define (parse-reader-lang-directive-text text span) + ;; `#lang reader` is the chaining-reader meta-language, so the payload after + ;; `reader` is a module path, not just a single language name token. Once the + ;; first line is known to be a `#lang` directive, keep the full text after + ;; `reader`, even when `module-lexer` reports the line as `error` in our + ;; snapshot setup. + (cond + [(regexp-match #px"^#lang\\s+reader[ \t]+([^\r\n]+)$" text) + => (lambda (match-data) + (define reader-payload (second match-data)) + (make-language-node 'reader-lang reader-payload span))] + [else #f])) + +(define (parse-plain-lang-directive-text text span) + (cond + [(regexp-match #px"^#lang\\s+(\\S+)$" text) + => (lambda (match-data) + (define language-name (second match-data)) + (make-language-node 'lang-directive language-name span))] + [else #f])) + +(define (malformed-lang-directive-text? text) + (and (string? text) + (string-prefix? text "#lang"))) + +(define (parse-lang-directive-node snapshot node) + ;; `module-lexer` uses `read-language` to classify language lines: resolved + ;; `#lang` forms become `lang-directive`, while failed resolution stays + ;; `error`. Preserve that distinction for plain `#lang`, but still recover + ;; `#lang reader ...` from `error` tokens because its payload is a module path + ;; that may be useful even when the chained reader cannot be loaded. + (match node + [(Token-Leaf span) + #:when (eq? 'lang-directive (LexerTokenSpan-type span)) + (parse-lang-directive-text (span-text snapshot span) span)] + [(Token-Leaf span) + #:when (eq? 'error (LexerTokenSpan-type span)) + (define text (span-text snapshot span)) + (or (parse-lang-directive-text text span) + ;; Explicitly recognize `#lang` error tokens as malformed language + ;; directives. + (and (malformed-lang-directive-text? text) + (make-language-node 'malformed-lang-directive "" span)))] + [_ #f])) + +(define (leaf-symbol-text snapshot node) + (match node + [(Token-Leaf span) + #:when (eq? 'symbol (LexerTokenSpan-type span)) + (span-text snapshot span)] + [_ #f])) + +(define (parse-reader-directive-node snapshot spans node next-idx) + ;; `read-language` is only for `#lang` lines, so `#reader` lines are handled + ;; syntactically. The lexer exposes the marker and the following reader name + ;; separately; keep the next non-skippable node as the reader text. + (match node + [(Token-Leaf span) + #:when (eq? 'reader-directive (LexerTokenSpan-type span)) + (define-values (reader-nodes _reader-idx) + (read-next-non-skippable-nodes/spans spans next-idx 1)) + (match reader-nodes + [(list reader-node) + (Language-Node + 'reader-directive + (token-node-text snapshot reader-node) + (LexerTokenSpan-start span) + (token-node-end reader-node))] + ['() + (make-language-node 'malformed-reader-directive "" span)])] + [_ #f])) + +(define (parse-raw-module-node snapshot node) + ;; Raw `(module name lang ...)` forms do not go through `read-language` either, + ;; so the language position is syntactic. If the first significant child is + ;; `module`, keep the third significant child as the language text even when it + ;; names an unknown module path; `parse-language` will decide whether it is + ;; known. + (match node + [(Token-Tree open-span children _close-span) + (define (node-symbol-text node) + (leaf-symbol-text snapshot node)) + + (match (read-next-non-skippable-nodes children 3) + [(list (app node-symbol-text "module") _mod-id mod-path-node) + (Language-Node + 'raw-module + (token-node-text snapshot mod-path-node) + (LexerTokenSpan-start open-span) + (token-node-end mod-path-node))] + [(list (app node-symbol-text "module") _ ...) + (Language-Node + 'malformed-raw-module + "" + (token-node-start node) + (token-node-end node))] + [_ #f])] + [_ #f])) + +(define (find-language-by-text text) + (for/or ([language (in-list known-languages)]) + (and (regexp-match? (Known-Language-name-rx language) text) + language))) + +(define (uri->suffix uri) + (define extension (path-get-extension (uri->path uri))) + (bytes->string/utf-8 (subbytes extension 1))) + +(define/contract (guess-language-by-uri uri) + (-> (or/c #f string?) + (or/c Known-Language? #f)) + (define maybe-suffix (and uri (uri->suffix uri))) + (and maybe-suffix + (for/or ([language (in-list known-languages)]) + (and (member maybe-suffix (Known-Language-suffixes language)) + language)))) + +(define/contract (parse-language-node source [idx 0]) + (->* ((or/c string? LexerSnapshot?)) + (exact-nonnegative-integer?) + (or/c Language-Node? #f)) + (define snapshot (source->snapshot source)) + (define spans (LexerSnapshot-tokens snapshot)) + (define-values (_skippable-nodes start-idx) + (parse-skippable-node spans idx)) + (cond + [(not (span-at spans start-idx)) #f] + [else + (define-values (node next-idx) + (parse-token-node spans start-idx)) + (or (parse-lang-directive-node snapshot node) + (parse-reader-directive-node snapshot spans node next-idx) + (parse-raw-module-node snapshot node))])) + +(define/contract (parse-language source [uri #f]) + (->* ((or/c string? LexerSnapshot?)) + ((or/c #f string?)) + (or/c Known-Language? 'unrecognized-language #f)) + (define language-node* (parse-language-node source)) + (cond + [language-node* + (or (find-language-by-text (Language-Node-text language-node*)) + 'unrecognized-language)] + [else (guess-language-by-uri uri)])) + +(define/contract (sexp-language? source [uri #f]) + (->* ((or/c string? LexerSnapshot?)) + ((or/c #f string?)) + boolean?) + (define maybe-language (parse-language source uri)) + (and (Known-Language? maybe-language) + (Known-Language-sexp? maybe-language))) + +(provide (struct-out Language-Node) + (struct-out Known-Language) + Known-Language~kw + known-languages + parse-language-node + parse-language + guess-language-by-uri + sexp-language?) diff --git a/doclib/lexer.rkt b/doclib/lexer.rkt index 9419696..c3425a9 100644 --- a/doclib/lexer.rkt +++ b/doclib/lexer.rkt @@ -257,6 +257,7 @@ entry)) (provide (struct-out LexerTokenSpan) + (struct-out LexerSnapshot) LexerSnapshot? token-node? sexp-comment-node? diff --git a/doclib/lexer/shared.rkt b/doclib/lexer/shared.rkt index 8635ca9..beaa33e 100644 --- a/doclib/lexer/shared.rkt +++ b/doclib/lexer/shared.rkt @@ -15,8 +15,10 @@ (LexerTokenSpan start end type))) (define (lang-directive? txt) - (string-prefix? txt "#lang ")) + (and (string? txt) + (string-prefix? txt "#lang "))) +;; Normalize tokens types to more meaningful. (define (normalize-token type text) (match* (type text) [('parenthesis (or "(" "[" "{")) @@ -33,7 +35,10 @@ [(_ "#,") 'syntax-unquote] [(_ ",@") 'unquote-splicing] [(_ "#reader") 'reader-directive] - [(_ (? lang-directive?)) 'lang-directive] + ;; lexer uses `read-language` to detect lang directives. + ;; Correct lang line are assigned `other` type, incorrect ones are assigned `error` type. + ;; We only handle correct ones here. + [('other (? lang-directive?)) 'lang-directive] [(_ _) type])) (define (span-at spans idx) diff --git a/doclib/lexer/token-tree.rkt b/doclib/lexer/token-tree.rkt index 5ef58c4..6acc6a9 100644 --- a/doclib/lexer/token-tree.rkt +++ b/doclib/lexer/token-tree.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "shared.rkt" + racket/list racket/match) ;; Token-Leaf: a single token span, representing a leaf in the token tree. @@ -23,6 +24,69 @@ (eq? 'sexp-comment (LexerTokenSpan-type (Token-Prefix-Tree-prefix-span value))))) +(define (skippable-span? span) + (memq (LexerTokenSpan-type span) '(white-space comment))) + +(define (non-skippable-node? node) + (not (or (and (Token-Leaf? node) + (skippable-span? (Token-Leaf-span node))) + (sexp-comment-node? node)))) + +;; Return up to `n` meaningful nodes from an already-built token tree, ignoring +;; whitespace, ordinary comments, and complete `#;` sexp-comment nodes. +(define (read-next-non-skippable-nodes nodes n) + (let loop ([nodes nodes] + [read-nodes '()]) + (cond + [(= (length read-nodes) n) (reverse read-nodes)] + [(null? nodes) (reverse read-nodes)] + [else + (define node (car nodes)) + (if (non-skippable-node? node) + (loop (cdr nodes) (cons node read-nodes)) + (loop (cdr nodes) read-nodes))]))) + +;; Parse up to `n` meaningful nodes directly from the token span vector, returning +;; the parsed nodes and the index where parsing stopped. Skippable spans before +;; each node are consumed but not included in the returned node list. +(define (read-next-non-skippable-nodes/spans spans idx n) + (let loop ([idx idx] + [read-nodes '()]) + (cond + [(= (length read-nodes) n) + (values (reverse read-nodes) idx)] + [else + (define-values (_skippable-nodes next-idx) + (parse-skippable-node spans idx)) + (cond + [(not (span-at spans next-idx)) + (values (reverse read-nodes) next-idx)] + [else + (define-values (node node-idx) + (parse-token-node spans next-idx)) + (loop node-idx (cons node read-nodes))])]))) + +(define (token-node-start node) + (match node + [(Token-Leaf span) (LexerTokenSpan-start span)] + [(Token-Tree open-span _children _close-span) + (LexerTokenSpan-start open-span)] + [(Token-Prefix-Tree prefix-span _skippable-nodes _child) + (LexerTokenSpan-start prefix-span)])) + +(define (token-node-end node) + (match node + [(Token-Leaf span) (LexerTokenSpan-end span)] + [(Token-Tree open-span children close-span) + (cond + [close-span (LexerTokenSpan-end close-span)] + [(null? children) (LexerTokenSpan-end open-span)] + [else (token-node-end (last children))])] + [(Token-Prefix-Tree prefix-span _skippable-nodes child) + (if child + (token-node-end child) + (LexerTokenSpan-end prefix-span))])) + ;; Skip over whitespaces and comments, accumulating them into `nodes` so they can be ;; preserved in the tree if needed. (define (parse-skippable-node spans idx [nodes '()]) @@ -85,6 +149,11 @@ (provide token-node? sexp-comment-node? + read-next-non-skippable-nodes + read-next-non-skippable-nodes/spans + token-node-start + token-node-end + parse-skippable-node parse-token-node (struct-out Token-Leaf) (struct-out Token-Tree) diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt new file mode 100644 index 0000000..d45c43d --- /dev/null +++ b/tests/lib/doc-lang-test.rkt @@ -0,0 +1,177 @@ +#lang racket + +(module+ test + (require rackunit + "../../doclib/doc-lang.rkt" + "../../doclib/lexer.rkt") + + (define (parse-node text) + (parse-language-node (build-lexer-snapshot text))) + + (define (parse-known-language text [uri #f]) + (parse-language (build-lexer-snapshot text) uri)) + + (define (language-name text [uri #f]) + (define language (parse-known-language text uri)) + (and (Known-Language? language) + (Known-Language-name language))) + + (define (node source text end) + (Language-Node source text 0 end)) + + (test-case + "Known-Language has a keyword constructor" + (check-equal? + (Known-Language~kw #:name 'demo + #:sexp? #t + #:suffixes '("demo") + #:name-rx #px"^demo$") + (Known-Language 'demo #t '("demo") #px"^demo$"))) + + (test-case + "parse-language-node recognizes an ordinary #lang line" + (check-equal? + (parse-node "#lang racket/base\n(define x 1)\n") + (node 'lang-directive "racket/base" (string-length "#lang racket/base")))) + + (test-case + "parse-language-node recognizes #lang reader wrappers" + (check-equal? + (parse-node "#lang reader syntax/module-reader\nracket/base\n") + (node 'reader-lang + "syntax/module-reader" + (string-length "#lang reader syntax/module-reader")))) + + (test-case + "parse-language-node keeps the full payload after #lang reader" + (check-equal? + (parse-node "#lang reader \"literal.rkt\"\nhello\n") + (node 'reader-lang + "\"literal.rkt\"" + (string-length "#lang reader \"literal.rkt\""))) + (check-equal? + (parse-node + "#lang reader (submod syntax/module-reader reader)\n1\n") + (node 'reader-lang + "(submod syntax/module-reader reader)" + (string-length + "#lang reader (submod syntax/module-reader reader)"))) + (check-equal? + (parse-node "#lang reader (foo)\n1\n") + (node 'reader-lang + "(foo)" + (string-length "#lang reader (foo)")))) + + (test-case + "parse-language-node recognizes #reader directives" + (check-equal? + (parse-node "#reader scribble/reader\n@title{demo}\n") + (node 'reader-directive + "scribble/reader" + (string-length "#reader scribble/reader"))) + (check-equal? + (parse-node "#reader (reader demo)\nbody\n") + (node 'reader-directive + "(reader demo)" + (string-length "#reader (reader demo)")))) + + (test-case + "parse-language-node recognizes raw modules" + (check-equal? + (parse-node "(module demo typed/racket/base (define x 1))\n") + (node 'raw-module + "typed/racket/base" + (string-length "(module demo typed/racket/base"))) + (check-equal? + (parse-node "(module demo (lib \"racket/base\") (define x 1))\n") + (node 'raw-module + "(lib \"racket/base\")" + (string-length "(module demo (lib \"racket/base\")"))) + (check-equal? + (parse-node "(module demo \"literal.rkt\" (define x 1))\n") + (node 'raw-module + "\"literal.rkt\"" + (string-length "(module demo \"literal.rkt\"")))) + + (test-case + "parse-language-node skips leading comments and sexp comments" + (check-equal? + (parse-node "; preamble\n#; (define ignored 1)\n#lang rhombus\nfun f(): 1\n") + (Language-Node 'lang-directive "rhombus" 33 46))) + + (test-case + "parse-language-node reports present but unrecognized selectors" + (check-equal? (parse-node "#lang \n(define x 1)\n") + (node 'malformed-lang-directive "" (string-length "#lang "))) + (check-equal? (parse-node "#lang reader\n(define x 1)\n") + (node 'malformed-lang-directive "" + (string-length "#lang reader\n(define x 1)"))) + (check-equal? (parse-node "#lang not-a-real-language\n1\n") + (node 'lang-directive + "not-a-real-language" + (string-length "#lang not-a-real-language"))) + (check-equal? (parse-node "#reader\n") + (node 'malformed-reader-directive "" (string-length "#reader"))) + (check-equal? (parse-node "#reader does/not/exist\n") + (node 'reader-directive + "does/not/exist" + (string-length "#reader does/not/exist"))) + (check-equal? (parse-node "(module demo does/not/exist (define x 1))\n") + (node 'raw-module + "does/not/exist" + (string-length "(module demo does/not/exist"))) + (check-equal? (parse-node "(module demo 1 (define x 1))\n") + (node 'raw-module + "1" + (string-length "(module demo 1"))) + (check-equal? (parse-node "(module demo)\n") + (Language-Node + 'malformed-raw-module + "" + 0 + (string-length "(module demo)"))) + (check-false (parse-node "(define x 1)\n(module demo racket/base x)\n"))) + + (test-case + "parse-language matches explicit known language families" + (check-equal? (language-name "#lang racket/base\n(define x 1)\n") + 'racket) + (check-equal? (language-name "#lang typed/racket/base\n(define x : Integer 1)\n") + 'typed/racket) + (check-equal? (language-name "#reader scribble/reader\n@title{demo}\n") + 'scribble) + (check-equal? (language-name "#lang rhombus\nfun f(): 1\n") + 'rhombus) + (check-equal? (parse-known-language "#lang not-a-real-language\n1\n") + 'unrecognized-language) + (check-equal? (parse-known-language "#reader does/not/exist\n") + 'unrecognized-language) + (check-equal? (parse-known-language "(module demo does/not/exist 1)\n") + 'unrecognized-language)) + + (test-case + "parse-language can fall back to distinctive suffixes" + (check-equal? (language-name "fun f(): 1\n" "file:///tmp/demo.rhm") + 'rhombus) + (check-equal? (language-name "@title{demo}\n" "file:///tmp/demo.scrbl") + 'scribble) + (check-false (language-name "(define x 1)\n" "file:///tmp/demo.rkt")) + (check-equal? (parse-known-language "#lang not-a-real-language\n1\n" + "file:///tmp/demo.rhm") + 'unrecognized-language)) + + (test-case + "guess-language-by-uri only uses distinctive suffixes" + (check-equal? (Known-Language-name (guess-language-by-uri "file:///tmp/demo.rhm")) + 'rhombus) + (check-equal? (Known-Language-name (guess-language-by-uri "file:///tmp/demo.scrbl")) + 'scribble) + (check-false (guess-language-by-uri "file:///tmp/demo.rkt"))) + + (test-case + "sexp-language? is true only for known sexp families" + (check-true (sexp-language? "#lang racket/base\n(define x 1)\n")) + (check-true (sexp-language? "(module demo typed/racket/base (define x 1))\n")) + (check-false (sexp-language? "#lang scribble/manual\n@title{demo}\n")) + (check-false (sexp-language? "fun f(): 1\n" "file:///tmp/demo.rhm")) + (check-false (sexp-language? "(define x 1)\n" "file:///tmp/demo.rkt")))) diff --git a/tests/lib/lexer-test.rkt b/tests/lib/lexer-test.rkt index 27c66bd..4a9e973 100644 --- a/tests/lib/lexer-test.rkt +++ b/tests/lib/lexer-test.rkt @@ -6,8 +6,7 @@ "../../doclib/lexer.rkt" (only-in "../../doclib/lexer/shared.rkt" make-lexer-span) - (only-in "../../doclib/lexer/token-tree.rkt" - parse-token-node) + "../../doclib/lexer/token-tree.rkt" "../../common/interfaces.rkt") (define (entry-summary entry) @@ -20,6 +19,10 @@ (for/list ([entry (in-lexer-snapshot (build-lexer-snapshot text))]) (entry-summary entry))) + (define (snapshot-entries text) + (for/list ([entry (in-lexer-snapshot (build-lexer-snapshot text))]) + entry)) + (test-case "build-lexer-snapshot enumerates public lexer entries" (define snapshot (build-lexer-snapshot "#lang racket\n(define x 1)\n")) @@ -46,11 +49,19 @@ (list 17 18 "\n" 'white-space)))) (test-case - "lexer snapshot keeps an invalid #lang payload in the same normalized shape" - (check-equal? - (take (snapshot-summaries "#lang not-a-real-language\n(define x 1)\n") 2) - (list (list 0 25 "#lang not-a-real-language" 'lang-directive) - (list 25 26 "\n" 'white-space)))) + "lexer snapshot preserves invalid #lang lines as errors" + (define unknown-language-summary + (first (snapshot-summaries "#lang not-a-real-language\n(define x 1)\n"))) + (check-equal? (list-ref unknown-language-summary 2) + "#lang not-a-real-language") + (check-equal? (list-ref unknown-language-summary 3) + 'error) + (define malformed-reader-summary + (first (snapshot-summaries "#lang reader (foo)\n1\n"))) + (check-equal? (list-ref malformed-reader-summary 2) + "#lang reader (foo)") + (check-equal? (list-ref malformed-reader-summary 3) + 'error)) (test-case "lexer snapshot normalizes #lang reader without collapsing the payload" @@ -133,6 +144,48 @@ (check-true (Token-Leaf? (Token-Prefix-Tree-child node))) (check-equal? next-index 3))) + (test-case + "token tree end uses the last child for unclosed lists" + (define-values (non-empty-node non-empty-next-index) + (parse-token-node + (vector (make-lexer-span 0 1 'open-paren) + (make-lexer-span 1 7 'symbol) + (make-lexer-span 7 8 'white-space) + (make-lexer-span 8 13 'symbol)) + 0)) + (check-equal? non-empty-next-index 4) + (check-equal? (token-node-end non-empty-node) 13) + + (define-values (empty-node empty-next-index) + (parse-token-node + (vector (make-lexer-span 0 1 'open-paren)) + 0)) + (check-equal? empty-next-index 1) + (check-equal? (token-node-end empty-node) 1)) + + (test-case + "token tree skips leading trivia and sexp comments" + (define spans + (vector (make-lexer-span 0 1 'white-space) + (make-lexer-span 1 2 'comment) + (make-lexer-span 2 4 'sexp-comment) + (make-lexer-span 4 5 'white-space) + (make-lexer-span 5 6 'symbol))) + (define-values (nodes next-index) + (parse-skippable-node spans 0)) + (check-equal? next-index 5) + (check-equal? (length nodes) 3) + (check-true (Token-Leaf? (first nodes))) + (check-equal? (LexerTokenSpan-type (Token-Leaf-span (first nodes))) + 'white-space) + (check-true (Token-Leaf? (second nodes))) + (check-equal? (LexerTokenSpan-type (Token-Leaf-span (second nodes))) + 'comment) + (check-true (Token-Prefix-Tree? (third nodes))) + (check-equal? (LexerTokenSpan-type + (Token-Prefix-Tree-prefix-span (third nodes))) + 'sexp-comment)) + (test-case "lexer snapshot position queries return token and symbol entries" (define snapshot From 0a583fe0ddac2b6dd601f1c870b6b969d786122e Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sun, 26 Apr 2026 20:20:16 +0800 Subject: [PATCH 04/17] Refactor uri->path using `compose` --- common/path-util.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/common/path-util.rkt b/common/path-util.rkt index 9174675..ee61c70 100644 --- a/common/path-util.rkt +++ b/common/path-util.rkt @@ -10,8 +10,7 @@ (define path->uri (compose url->string path->url)) -(define (uri->path uri) - (path->string (url->path (string->url uri)))) +(define uri->path (compose path->string url->path string->url)) (define (directory-contains? dir filepath) (define dir-parts (explode-path (simple-form-path dir))) From 2d36c75721db7fdcda642378241b2f862c34ed03 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sun, 26 Apr 2026 21:22:43 +0800 Subject: [PATCH 05/17] Add language declaration diagnostics - Stop pass indenter to services, it's not used by them - Improve dignostics module - Skip formatting for not-Sexp languages - Move indenter lookup into doc-lang.rkt --- doclib/check-syntax.rkt | 20 +---- doclib/doc-lang.rkt | 11 ++- doclib/doc-trace.rkt | 5 +- doclib/doc.rkt | 17 ++-- doclib/service/diagnostic.rkt | 124 ++++++++++++++++++++-------- scribblings/racket-langserver.scrbl | 4 +- tests/client.rkt | 9 +- tests/lib/doc-lang-test.rkt | 15 +++- tests/lib/doc-test.rkt | 110 ++++++++++++++++++++++-- tests/sync/diagnostics.json | 7 +- tests/sync/test.rkt | 12 +-- 11 files changed, 246 insertions(+), 88 deletions(-) diff --git a/doclib/check-syntax.rkt b/doclib/check-syntax.rkt index 3c5e39c..18e1c50 100644 --- a/doclib/check-syntax.rkt +++ b/doclib/check-syntax.rkt @@ -10,23 +10,6 @@ "../common/path-util.rkt" "internal-types.rkt") -(define (get-indenter text) - (define lang-info - (with-handlers ([exn:fail:read? (lambda (e) 'missing)] - [exn:missing-module? (lambda (e) #f)]) - (read-language (open-input-string text) (lambda () 'missing)))) - (cond - [(procedure? lang-info) - (lang-info 'drracket:indentation #f)] - [(eq? lang-info 'missing) - ; check for a #reader directive at start of file, ignoring comments - ; the ^ anchor here matches start-of-string, not start-of-line - (if (regexp-match #rx"^(;[^\n]*\n)*#reader" text) - #f ; most likely a drracket file, use default indentation - ; (https://github.com/jeapostrophe/racket-langserver/issues/86) - 'missing)] - [else #f])) - ;; TODO: cache the namespace with some strategy (define (expand-source path in collector) (define-values (src-dir _1 _2) (split-path path)) @@ -71,8 +54,7 @@ (define (check-syntax uri doc-text) (define path (uri->path uri)) (define text (send doc-text get-text)) - (define indenter (get-indenter text)) - (define new-trace (new build-trace% [src path] [doc-text doc-text] [indenter indenter])) + (define new-trace (new build-trace% [src path] [doc-text doc-text])) (define in (open-input-string text)) (define er (expand-source path in new-trace)) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index 010335d..b598900 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -244,11 +244,20 @@ (and (Known-Language? maybe-language) (Known-Language-sexp? maybe-language))) +(define/contract (get-indenter text) + (-> string? (or/c procedure? #f)) + (define maybe-language-info + (read-language (open-input-string text) (lambda () #f))) + (and (procedure? maybe-language-info) + (maybe-language-info 'drracket:indentation #f))) + (provide (struct-out Language-Node) (struct-out Known-Language) Known-Language~kw known-languages + find-language-by-text parse-language-node parse-language guess-language-by-uri - sexp-language?) + sexp-language? + get-indenter) diff --git a/doclib/doc-trace.rkt b/doclib/doc-trace.rkt index e62bc44..83d1c7e 100644 --- a/doclib/doc-trace.rkt +++ b/doclib/doc-trace.rkt @@ -14,13 +14,13 @@ (define build-trace% (class (annotations-mixin object%) - (init-field src doc-text indenter) + (init-field src doc-text) (define hovers (new hover%)) (define docs (new docs%)) (define completions (new completion%)) (define requires (new require%)) (define definitions (new definition% [src src])) - (define diag (new diag% [src src] [doc-text doc-text] [indenter indenter])) + (define diag (new diag% [src src] [doc-text doc-text])) (define decls (new declaration%)) (define workspace-references (new workspace-references% [src src] [doc-text doc-text])) (define semantic-tokens (new highlight% [src src] [doc-text doc-text])) @@ -57,7 +57,6 @@ (send s walk-log text))) ;; Getters - (define/public (get-indenter) indenter) (define/public (get-warn-diags) (car (send diag get))) (define/public (get-hovers) (send hovers get)) (define/public (get-docs) (send docs get)) diff --git a/doclib/doc.rkt b/doclib/doc.rkt index 688236f..94167ae 100644 --- a/doclib/doc.rkt +++ b/doclib/doc.rkt @@ -13,6 +13,7 @@ "formatting.rkt" "internal-types.rkt" "lexer.rkt" + "doc-lang.rkt" racket/match racket/contract racket/class @@ -44,7 +45,7 @@ (define doc-text (new lsp-editor%)) (send doc-text insert text 0) ;; the init trace should not be #f - (define doc-trace (new build-trace% [src (uri->path uri)] [doc-text doc-text] [indenter #f])) + (define doc-trace (new build-trace% [src (uri->path uri)] [doc-text doc-text])) (Doc uri doc-text doc-trace version #f (list) (make-lazy-cache))) (define (invalidate-resyntax-results! doc) @@ -337,11 +338,15 @@ (define doc-text (Doc-text doc)) (define-values (start-line end-line) (formatting-range->lines doc-text fmt-range)) - (formatting (send doc-text get-text) - start-line - end-line - #:src-dir (doc-src-dir doc) - #:interactive? on-type?)) + (define text (send doc-text get-text)) + (cond + [(sexp-language? text (Doc-uri doc)) + (formatting text + start-line + end-line + #:src-dir (doc-src-dir doc) + #:interactive? on-type?)] + [else '()])) ;; get the tokens whose range are contained in interval [pos-start, pos-end) ;; the tokens whose range intersects the given range is included. diff --git a/doclib/service/diagnostic.rkt b/doclib/service/diagnostic.rkt index e976b6f..4d179dc 100644 --- a/doclib/service/diagnostic.rkt +++ b/doclib/service/diagnostic.rkt @@ -4,13 +4,13 @@ racket/class racket/string racket/set - racket/sandbox racket/match racket/list setup/path-to-relative data/interval-map "../../common/interfaces.rkt" "../internal-types.rkt" + "../doc-lang.rkt" "../../common/path-util.rkt" drracket/check-syntax) @@ -18,7 +18,7 @@ (define diag% (class base-service% - (init-field src doc-text indenter) + (init-field src doc-text) (super-new) (define diags (mutable-seteq)) @@ -42,13 +42,9 @@ (define/override (walk-stx expand-result) (define pre-exn (ExpandResult-pre-exn expand-result)) (define post-exn (ExpandResult-post-exn expand-result)) - (when (eq? indenter 'missing) - (add-diag! - (Diagnostic #:range (Range #:start (Pos #:line 0 #:char 0) - #:end (Pos #:line 0 #:char 0)) - #:severity DiagnosticSeverity-Error - #:source "Racket" - #:message "Missing or invalid #lang line"))) + (define maybe-language-diag (language-diagnostic doc-text)) + (when maybe-language-diag + (add-diag! maybe-language-diag)) (when pre-exn (add-diags! (error-diagnostics doc-text pre-exn))) (when post-exn @@ -61,7 +57,8 @@ (add-diags! result)))) (define/override (syncheck:add-mouse-over-status src-obj start finish text) - (when (string=? "no bound occurrences" text) + (when (and (< start finish) + (string=? "no bound occurrences" text)) (hint-unused-variable src-obj start finish))) ;; Mouse-over status @@ -98,20 +95,73 @@ #:message "unused require")) (add-diag! diag)))) +(define language-diagnostic-source "Language Declaration Check") + +;; Return a diagnostic for a missing or unrecognized source language declaration. +(define (language-diagnostic doc-text) + (define text (send doc-text get-text)) + (define maybe-language-node (parse-language-node text)) + (cond + [(not maybe-language-node) + (language-error-diag + (first-line-range doc-text) + "Missing language declaration. Add a `#lang` line, `#reader`, or `(module ... ...)` form.")] + [(find-language-by-text (Language-Node-text maybe-language-node)) #f] + [else + (language-error-diag + (language-node-range doc-text maybe-language-node) + (unrecognized-language-message maybe-language-node))])) + +(define (language-error-diag range message) + (Diagnostic #:range range + #:severity DiagnosticSeverity-Error + #:source language-diagnostic-source + #:message message)) + +(define (empty-range? range) + (define start (Range-start range)) + (define end (Range-end range)) + (and (= (Pos-line start) (Pos-line end)) + (= (Pos-char start) (Pos-char end)))) + +(define (nonempty-diagnostic-range doc-text range) + (if (empty-range? range) + (first-line-range doc-text) + range)) + +(define (first-line-range doc-text) + (define start (send doc-text line-start-pos 0)) + (define end (send doc-text line-end-pos 0)) + (Range #:start (abs-pos->Pos doc-text start) + #:end (abs-pos->Pos doc-text end))) + +(define (language-node-range doc-text language-node) + (nonempty-diagnostic-range + doc-text + (Range #:start (abs-pos->Pos doc-text (Language-Node-start language-node)) + #:end (abs-pos->Pos doc-text (Language-Node-end language-node))))) + +(define (unrecognized-language-message language-node) + (define language-text (Language-Node-text language-node)) + (cond + [(not (string=? "" language-text)) + (format + "Unrecognized language declaration `~a`. Check the language name or reader path." + language-text)] + [else + "Unrecognized language declaration. Check the language name after `#lang`, `#reader`, or in `(module ... ...)`."])) + (define (error-diagnostics doc-text exn) (define msg (exn-message exn)) (cond - ;; typed racket support: don't report error summaries + ;; Typed Racket reports each type error separately, then emits a final + ;; "Type Checker: Summary" message that repeats the error count. The + ;; per-error diagnostics are more useful, so do not publish the summary. [(string-prefix? msg "Type Checker: Summary") (list)] - [(exn:fail:resource? exn) - (list (Diagnostic #:range (Range #:start (Pos #:line 0 #:char 0) - #:end (Pos #:line 0 #:char 0)) - #:severity DiagnosticSeverity-Hint - #:source "Expander" - #:message "the expand time has exceeded the 90s limit.\ - Check if your macro is infinitely expanding"))] + ;; A .zo file was compiled by a different Racket version. The original + ;; reader error is hard to act on, so rewrite it into a recompilation + ;; suggestion for the library or compiled file named in the message. [(and (exn:fail:read? exn) - ;; Looking for the pattern '... version mismatch ... .zo ... raco setup ...' (regexp-match? #rx"version mismatch.*\\.zo.*raco setup" msg)) (define maybe-error-source-mtchs/f (regexp-match #rx"in: (.*\\.zo)" msg)) @@ -142,42 +192,45 @@ msg)] [else msg])) ;; stub range -- see the comments in exn:missing-module? - (list (Diagnostic #:range (Range #:start (Pos #:line 0 #:char 0) - #:end (Pos #:line 0 #:char 0)) + (list (Diagnostic #:range (first-line-range doc-text) #:severity DiagnosticSeverity-Error #:source "Racket" #:message expanded-msg))] + ;; Most reader, expander, and typechecker errors carry one or more srclocs. + ;; Turn each reported srcloc into a diagnostic, falling back to the first + ;; line only when Racket reports the error without a usable position. [(exn:srclocs? exn) (define srclocs ((exn:srclocs-accessor exn) exn)) (for/list ([sl (in-list srclocs)]) (match-define (srcloc src line col pos span) sl) (if (and (number? line) (number? col) (number? span)) - (Diagnostic #:range (Range #:start (Pos #:line (sub1 line) #:char col) - #:end (Pos #:line (sub1 line) #:char (+ col span))) + (Diagnostic #:range (nonempty-diagnostic-range + doc-text + (Range #:start (Pos #:line (sub1 line) #:char col) + #:end (Pos #:line (sub1 line) #:char (+ col span)))) #:severity DiagnosticSeverity-Error #:source "Racket" #:message msg) ;; Some reader exceptions don't report a position - ;; Use end of file as a reasonable guess - (let ([end-of-file (abs-pos->Pos doc-text (send doc-text end-pos))]) - (Diagnostic #:range (Range #:start end-of-file - #:end end-of-file) - #:severity DiagnosticSeverity-Error - #:source "Racket" - #:message msg))))] + (Diagnostic #:range (first-line-range doc-text) + #:severity DiagnosticSeverity-Error + #:source "Racket" + #:message msg)))] + ;; Missing module exceptions tell us which module could not be loaded, but + ;; not which `require` form in the user's file triggered the lookup. Publish + ;; the message at a document-level range instead of guessing the require. [(exn:missing-module? exn) ;; Hack: ;; We do not have any source location for the offending `require`, but the language - ;; server protocol requires a valid range object. So we punt and just highlight the - ;; first character. + ;; server protocol requires a valid range object. So highlight the first line. ;; This is very close to DrRacket's behavior: it also has no source location to work with, ;; however it simply doesn't highlight any code. - (define silly-range - (Range #:start (Pos #:line 0 #:char 0) #:end (Pos #:line 0 #:char 0))) - (list (Diagnostic #:range silly-range + (list (Diagnostic #:range (first-line-range doc-text) #:severity DiagnosticSeverity-Error #:source "Racket" #:message msg))] + ;; If a new kind of expansion failure reaches this point, fail loudly so we + ;; can decide how to map it into an LSP diagnostic. [else (error 'error-diagnostics "unexpected failure: ~a" exn)])) (define (check-typed-racket-log doc-text log) @@ -197,4 +250,3 @@ #:severity DiagnosticSeverity-Error #:source "Typed Racket" #:message msg)))))) - diff --git a/scribblings/racket-langserver.scrbl b/scribblings/racket-langserver.scrbl index 03f9cc4..cd1ac62 100644 --- a/scribblings/racket-langserver.scrbl +++ b/scribblings/racket-langserver.scrbl @@ -699,8 +699,8 @@ Exceptions are noted in individual entries. [#:on-type? on-type? boolean? #f]) (or/c (listof TextEdit?) #f)]{ Computes formatting edits for the lines covered by @tt{fmt-range}. - Returns a list of @racket[TextEdit] values to apply, or @racket[#f] if no - indenter is available (e.g., the document lacks a @tt{#lang} line). + Returns a list of @racket[TextEdit] values to apply. For documents without + a recognized s-expression language, returns an empty list. When @tt{on-type?} is @racket[#t], blank lines are indented too. This mode is intended for on-type formatting triggered by pressing Enter. diff --git a/tests/client.rkt b/tests/client.rkt index f77bdb7..9422d44 100644 --- a/tests/client.rkt +++ b/tests/client.rkt @@ -6,6 +6,7 @@ client-send client-wait-response client-wait-notification + client-has-diagnostic? make-request make-expected-response make-notification) @@ -15,6 +16,7 @@ racket/match racket/runtime-path json + "../common/json-util.rkt" "../lsp/methods.rkt") (define id 0) @@ -109,6 +111,12 @@ (define (client-wait-notification lsp) (async-channel-get (notification-channel))) +(define/contract (client-has-diagnostic? notification expected-diagnostic) + (-> jsexpr? hash? boolean?) + + (for/or ([diagnostic (in-list (jsexpr-ref notification '(params diagnostics)))]) + (equal? diagnostic expected-diagnostic))) + (define/contract (make-request lsp method params) (-> any/c string? jsexpr? jsexpr?) @@ -136,4 +144,3 @@ 'method method)) (cond [(not params) req] [else (hash-set req 'params params)])) - diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt index d45c43d..71673a0 100644 --- a/tests/lib/doc-lang-test.rkt +++ b/tests/lib/doc-lang-test.rkt @@ -149,6 +149,14 @@ (check-equal? (parse-known-language "(module demo does/not/exist 1)\n") 'unrecognized-language)) + (test-case + "find-language-by-text matches known families" + (check-equal? (Known-Language-name (find-language-by-text "racket/base")) + 'racket) + (check-equal? (Known-Language-name (find-language-by-text "typed/racket/base")) + 'typed/racket) + (check-false (find-language-by-text "not-a-real-language"))) + (test-case "parse-language can fall back to distinctive suffixes" (check-equal? (language-name "fun f(): 1\n" "file:///tmp/demo.rhm") @@ -174,4 +182,9 @@ (check-true (sexp-language? "(module demo typed/racket/base (define x 1))\n")) (check-false (sexp-language? "#lang scribble/manual\n@title{demo}\n")) (check-false (sexp-language? "fun f(): 1\n" "file:///tmp/demo.rhm")) - (check-false (sexp-language? "(define x 1)\n" "file:///tmp/demo.rkt")))) + (check-false (sexp-language? "(define x 1)\n" "file:///tmp/demo.rkt"))) + + (test-case + "get-indenter returns a procedure or false" + (check-false (get-indenter "(define x 1)\n")) + (check-true (procedure? (get-indenter "#lang rhombus\nfun f(): 1\n"))))) diff --git a/tests/lib/doc-test.rkt b/tests/lib/doc-test.rkt index 0c60448..679b980 100644 --- a/tests/lib/doc-test.rkt +++ b/tests/lib/doc-test.rkt @@ -4,6 +4,7 @@ (require rackunit "../../doclib/doc.rkt" "../../doclib/doc-trace.rkt" + "../../doclib/check-syntax.rkt" "../../doclib/editor.rkt" "../../doclib/internal-types.rkt" "../../common/interfaces.rkt" @@ -186,7 +187,7 @@ (test-case "Formatting" ;; doc.rkt `doc-format-edits` delegates to the external formatter. - (define text "(define x\n1)") + (define text "#lang racket/base\n(define x\n1)") (define d (make-doc "file:///test.rkt" text)) (define opts (FormattingOptions #:tab-size 2 @@ -242,9 +243,103 @@ #:formatting-options opts) (list (TextEdit (Range (Pos 3 0) (Pos 3 0)) " ")))) + (test-case + "Formatting language guard" + (define opts + (FormattingOptions #:tab-size 2 + #:insert-spaces #t + #:trim-trailing-whitespace #t + #:insert-final-newline #f + #:trim-final-newlines #f + #:key #f)) + + (define raw-doc + (make-doc "file:///test.rkt" "(define x\n1)")) + (check-equal? + (doc-format-edits raw-doc + (Range (Pos 0 0) (Pos 2 0)) + #:formatting-options opts) + '()) + + (define rhombus-doc + (make-doc "file:///test.rhm" + "#lang rhombus\n fun f():\n 1\n")) + (check-equal? + (doc-format-edits rhombus-doc + (Range (Pos 0 0) (Pos 3 0)) + #:formatting-options opts) + '())) + + (define (find-diagnostic-by-message diags expected-message) + (for/first ([diag (in-list diags)] + #:when (string=? (Diagnostic-message diag) expected-message)) + diag)) + + (define (check-syntax-diagnostics uri text) + (define doc-text (new lsp-editor%)) + (send doc-text insert text 0) + (set->list (send (CSResult-trace (check-syntax uri doc-text)) get-warn-diags))) + + (test-case + "Document diagnostics report missing language declarations" + (define text "(define x 1)\n") + (define diags + (check-syntax-diagnostics "file:///tmp/missing-language-test.rkt" + text)) + (define diag + (find-diagnostic-by-message + diags + "Missing language declaration. Add a `#lang` line, `#reader`, or `(module ... ...)` form.")) + (check-not-false diag) + (check-equal? (Diagnostic-source diag) "Language Declaration Check") + (define range (Diagnostic-range diag)) + (check-equal? (Pos-line (Range-start range)) 0) + (check-equal? (Pos-char (Range-start range)) 0) + (check-equal? (Pos-line (Range-end range)) 0) + (check-equal? (Pos-char (Range-end range)) + (string-length "(define x 1)"))) + + (test-case + "Document diagnostics report unrecognized language declarations" + (define text "#lang not-a-real-language\n1\n") + (define diags + (check-syntax-diagnostics "file:///tmp/unrecognized-language-test.rkt" + text)) + (define diag + (find-diagnostic-by-message + diags + "Unrecognized language declaration `not-a-real-language`. Check the language name or reader path.")) + (check-not-false diag) + (check-equal? (Diagnostic-source diag) "Language Declaration Check") + (define range (Diagnostic-range diag)) + (check-equal? (Pos-line (Range-start range)) 0) + (check-equal? (Pos-char (Range-start range)) 0) + (check-equal? (Pos-line (Range-end range)) 0) + (check-equal? (Pos-char (Range-end range)) + (string-length "#lang not-a-real-language"))) + + (test-case + "Document diagnostics use first line range for empty language spans" + (define text "#lang \n(define x 1)\n") + (define diags + (check-syntax-diagnostics "file:///tmp/empty-language-test.rkt" + text)) + (define diag + (find-diagnostic-by-message + diags + "Unrecognized language declaration. Check the language name after `#lang`, `#reader`, or in `(module ... ...)`.")) + (check-not-false diag) + (check-equal? (Diagnostic-source diag) "Language Declaration Check") + (define range (Diagnostic-range diag)) + (check-equal? (Pos-line (Range-start range)) 0) + (check-equal? (Pos-char (Range-start range)) 0) + (check-equal? (Pos-line (Range-end range)) 0) + (check-equal? (Pos-char (Range-end range)) + (string-length "#lang "))) + (test-case "Apply TextEdits" - (define text "(define x\n1)") + (define text "#lang racket/base\n(define x\n1)") (define d (make-doc "file:///test.rkt" text)) (define opts (FormattingOptions #:tab-size 2 @@ -256,12 +351,12 @@ (define edits (doc-format-edits d (Range (Pos 0 0) (Pos 2 0)) #:formatting-options opts)) (check-equal? edits - (list (TextEdit (Range (Pos 1 0) (Pos 1 2)) " 1)"))) - (check-equal? (LexerEntry-type (doc-token-at d 1)) 'symbol) + (list (TextEdit (Range (Pos 2 0) (Pos 2 2)) " 1)"))) + (check-equal? (LexerEntry-type (doc-token-at d 19)) 'symbol) (doc-apply-edits! d edits) - (check-equal? (doc-get-text d) "(define x\n 1)") + (check-equal? (doc-get-text d) "#lang racket/base\n(define x\n 1)") (define updated-token - (doc-token-at d (doc-pos->abs-pos d (Pos 1 2)))) + (doc-token-at d (doc-pos->abs-pos d (Pos 2 2)))) (check-true (LexerEntry? updated-token)) (check-equal? (LexerEntry-type updated-token) 'constant) (check-equal? (LexerEntry-text updated-token) "1")) @@ -323,8 +418,7 @@ END (define test-trace% (class build-trace% (super-new [src (string->path "/tmp/completion-prefix-test.rkt")] - [doc-text (new lsp-editor%)] - [indenter #f]) + [doc-text (new lsp-editor%)]) (define/override (get-completions) '()) (define/override (get-online-completions str-before-cursor) (hash-ref prefix->completions str-before-cursor '())))) diff --git a/tests/sync/diagnostics.json b/tests/sync/diagnostics.json index 07659ba..e81a1ee 100644 --- a/tests/sync/diagnostics.json +++ b/tests/sync/diagnostics.json @@ -1,7 +1,7 @@ { "range": { "end": { - "character": 0, + "character": 11, "line": 0 }, "start": { @@ -10,5 +10,6 @@ } }, "severity": 1, - "source": "Racket" -} \ No newline at end of file + "source": "Language Declaration Check", + "message": "Unrecognized language declaration `racke`. Check the language name or reader path." +} diff --git a/tests/sync/test.rkt b/tests/sync/test.rkt index 998d7d3..d0ef944 100644 --- a/tests/sync/test.rkt +++ b/tests/sync/test.rkt @@ -22,14 +22,10 @@ (client-send lsp didopen-req) (let ([resp (client-wait-notification lsp)]) (check-true (jsexpr-has-key? resp '(params diagnostics))) - (define diagnostics-msg (jsexpr-ref resp '(params diagnostics))) - (check-false (null? diagnostics-msg)) - (define dm (with-input-from-string - (jsexpr->string (car diagnostics-msg)) - (lambda () (read-json)))) - (define resp-no-message (hash-remove dm 'message)) - (check-equal? (jsexpr->string resp-no-message) - (jsexpr->string (read-json (open-input-file "diagnostics.json"))))) + (check-false (null? (jsexpr-ref resp '(params diagnostics)))) + (check-true + (client-has-diagnostic? resp + (read-json (open-input-file "diagnostics.json"))))) (define didchange-req From 10e18752aee25f15e67b14480b47d8edac9c2e06 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sun, 26 Apr 2026 21:28:35 +0800 Subject: [PATCH 06/17] Handle the collection not found exception when not installed And make test not require rhombus installed. --- doclib/doc-lang.rkt | 4 +++- tests/lib/doc-lang-test.rkt | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index b598900..3479bc7 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -247,7 +247,9 @@ (define/contract (get-indenter text) (-> string? (or/c procedure? #f)) (define maybe-language-info - (read-language (open-input-string text) (lambda () #f))) + (with-handlers ([exn:fail:read? (lambda (_e) #f)] + [exn:missing-module? (lambda (_e) #f)]) + (read-language (open-input-string text) (lambda () #f)))) (and (procedure? maybe-language-info) (maybe-language-info 'drracket:indentation #f))) diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt index 71673a0..3d7d0f9 100644 --- a/tests/lib/doc-lang-test.rkt +++ b/tests/lib/doc-lang-test.rkt @@ -187,4 +187,5 @@ (test-case "get-indenter returns a procedure or false" (check-false (get-indenter "(define x 1)\n")) - (check-true (procedure? (get-indenter "#lang rhombus\nfun f(): 1\n"))))) + (check-true (procedure? (get-indenter "#lang scribble/manual\n@title{demo}\n"))) + (check-false (get-indenter "#lang does/not/exist\n1\n")))) From 2e591dc130ee188d9124331e1a865b9def718340 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sun, 26 Apr 2026 21:43:01 +0800 Subject: [PATCH 07/17] Handle GTK init failed error when calling read-language Also removed get-indenter test because it returns false now for all builtin languages. --- doclib/doc-lang.rkt | 16 ++++++++++------ tests/lib/doc-lang-test.rkt | 8 +------- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index 3479bc7..c69b976 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -244,14 +244,18 @@ (and (Known-Language? maybe-language) (Known-Language-sexp? maybe-language))) +(define (indenter-load-failure? e) + (or (exn:fail:read? e) + (exn:missing-module? e) + (string-contains? (exn-message e) "Gtk initialization failed for display"))) + (define/contract (get-indenter text) (-> string? (or/c procedure? #f)) - (define maybe-language-info - (with-handlers ([exn:fail:read? (lambda (_e) #f)] - [exn:missing-module? (lambda (_e) #f)]) - (read-language (open-input-string text) (lambda () #f)))) - (and (procedure? maybe-language-info) - (maybe-language-info 'drracket:indentation #f))) + (with-handlers ([indenter-load-failure? (lambda (_e) #f)]) + (define maybe-language-info + (read-language (open-input-string text) (lambda () #f))) + (and (procedure? maybe-language-info) + (maybe-language-info 'drracket:indentation #f)))) (provide (struct-out Language-Node) (struct-out Known-Language) diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt index 3d7d0f9..49b786f 100644 --- a/tests/lib/doc-lang-test.rkt +++ b/tests/lib/doc-lang-test.rkt @@ -182,10 +182,4 @@ (check-true (sexp-language? "(module demo typed/racket/base (define x 1))\n")) (check-false (sexp-language? "#lang scribble/manual\n@title{demo}\n")) (check-false (sexp-language? "fun f(): 1\n" "file:///tmp/demo.rhm")) - (check-false (sexp-language? "(define x 1)\n" "file:///tmp/demo.rkt"))) - - (test-case - "get-indenter returns a procedure or false" - (check-false (get-indenter "(define x 1)\n")) - (check-true (procedure? (get-indenter "#lang scribble/manual\n@title{demo}\n"))) - (check-false (get-indenter "#lang does/not/exist\n1\n")))) + (check-false (sexp-language? "(define x 1)\n" "file:///tmp/demo.rkt")))) From 1dfc17e8e87ef39ff01cf690de8912dc93a6b547 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Mon, 27 Apr 2026 20:52:11 +0800 Subject: [PATCH 08/17] Return a empty result, not request cancel error when doc closed --- lsp/text-document.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/lsp/text-document.rkt b/lsp/text-document.rkt index 85557a3..6f5edfc 100644 --- a/lsp/text-document.rkt +++ b/lsp/text-document.rkt @@ -336,9 +336,7 @@ (λ (signal) (cond [(signal-doc-close? signal) - (error-response id - ErrorCode-RequestCancelled - "textDocument/semanticTokens request was cancelled because the document closed")] + (success/enc id (hash 'data '()))] [else (define tokens (with-read-doc safe-doc From d325aa1e517a11cbba562314774c939adfe96d28 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Mon, 11 May 2026 12:02:53 +0800 Subject: [PATCH 09/17] Rename language nodes to prefixes --- .lispwords | 1 + doclib/doc-lang.rkt | 187 +++++++++++++++++++++------------- doclib/lexer/scan.rkt | 118 +++++++++++++++++++++ doclib/lexer/shared.rkt | 42 ++------ doclib/service/diagnostic.rkt | 20 ++-- tests/lib/doc-lang-test.rkt | 173 +++++++++++++++++-------------- 6 files changed, 348 insertions(+), 193 deletions(-) create mode 100644 doclib/lexer/scan.rkt diff --git a/.lispwords b/.lispwords index 5a00c43..edfbf12 100644 --- a/.lispwords +++ b/.lispwords @@ -15,3 +15,4 @@ (call-with-write-lock 1) (define-syntax-parse-rule 1) (with-limits 2) +(and-let* 1) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index c69b976..02bd16c 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -1,7 +1,7 @@ #lang racket/base (require "../common/path-util.rkt" - "lexer.rkt" + "lexer/scan.rkt" "lexer/shared.rkt" "lexer/token-tree.rkt" racket/contract @@ -10,7 +10,7 @@ racket/path racket/string) -(define language-node-source/c +(define language-prefix-source/c (or/c ;; `#lang racket/base` 'lang-directive @@ -27,11 +27,12 @@ ;; `(module name racket/base ...)` 'raw-module)) -(struct/contract Language-Node - ([source language-node-source/c] +(struct/contract Language-Prefix + ([source language-prefix-source/c] [text string?] [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?]) + [end exact-nonnegative-integer?] + [body-start-idx exact-nonnegative-integer?]) #:transparent) (struct/contract Known-Language @@ -66,32 +67,35 @@ #:suffixes '("rhm") #:name-rx #px"^rhombus(?:/.*)?$"))) -(define (source->snapshot source) +(define (source->text+spans source) (cond - [(LexerSnapshot? source) source] - [(string? source) (build-lexer-snapshot source)])) + [(LexerSnapshot? source) + (values (LexerSnapshot-text source) (LexerSnapshot-tokens source))] + [(string? source) + (values source (text->lexer-token-spans source))])) -(define (span-text snapshot span) - (substring (LexerSnapshot-text snapshot) +(define (span-text text span) + (substring text (LexerTokenSpan-start span) (LexerTokenSpan-end span))) -(define (token-node-text snapshot node) - (substring (LexerSnapshot-text snapshot) +(define (token-node-text text node) + (substring text (token-node-start node) (token-node-end node))) -(define (make-language-node source text span) - (Language-Node source - text - (LexerTokenSpan-start span) - (LexerTokenSpan-end span))) +(define (make-language-prefix source text span body-start-idx) + (Language-Prefix source + text + (LexerTokenSpan-start span) + (LexerTokenSpan-end span) + body-start-idx)) -(define (parse-lang-directive-text text span) - (or (parse-reader-lang-directive-text text span) - (parse-plain-lang-directive-text text span))) +(define (parse-lang-directive-text text span header-end) + (or (parse-reader-lang-directive-text text span header-end) + (parse-plain-lang-directive-text text span header-end))) -(define (parse-reader-lang-directive-text text span) +(define (parse-reader-lang-directive-text text span header-end) ;; `#lang reader` is the chaining-reader meta-language, so the payload after ;; `reader` is a module path, not just a single language name token. Once the ;; first line is known to be a `#lang` directive, keep the full text after @@ -101,22 +105,22 @@ [(regexp-match #px"^#lang\\s+reader[ \t]+([^\r\n]+)$" text) => (lambda (match-data) (define reader-payload (second match-data)) - (make-language-node 'reader-lang reader-payload span))] + (make-language-prefix 'reader-lang reader-payload span header-end))] [else #f])) -(define (parse-plain-lang-directive-text text span) +(define (parse-plain-lang-directive-text text span header-end) (cond [(regexp-match #px"^#lang\\s+(\\S+)$" text) => (lambda (match-data) (define language-name (second match-data)) - (make-language-node 'lang-directive language-name span))] + (make-language-prefix 'lang-directive language-name span header-end))] [else #f])) (define (malformed-lang-directive-text? text) (and (string? text) (string-prefix? text "#lang"))) -(define (parse-lang-directive-node snapshot node) +(define (parse-lang-directive-node text node next-idx) ;; `module-lexer` uses `read-language` to classify language lines: resolved ;; `#lang` forms become `lang-directive`, while failed resolution stays ;; `error`. Preserve that distinction for plain `#lang`, but still recover @@ -125,70 +129,70 @@ (match node [(Token-Leaf span) #:when (eq? 'lang-directive (LexerTokenSpan-type span)) - (parse-lang-directive-text (span-text snapshot span) span)] + (parse-lang-directive-text (span-text text span) span next-idx)] [(Token-Leaf span) #:when (eq? 'error (LexerTokenSpan-type span)) - (define text (span-text snapshot span)) - (or (parse-lang-directive-text text span) + (define token-text (span-text text span)) + (or (parse-lang-directive-text token-text span next-idx) ;; Explicitly recognize `#lang` error tokens as malformed language ;; directives. - (and (malformed-lang-directive-text? text) - (make-language-node 'malformed-lang-directive "" span)))] + (and (malformed-lang-directive-text? token-text) + (make-language-prefix 'malformed-lang-directive "" span next-idx)))] [_ #f])) -(define (leaf-symbol-text snapshot node) +(define (leaf-symbol-text text node) (match node [(Token-Leaf span) #:when (eq? 'symbol (LexerTokenSpan-type span)) - (span-text snapshot span)] + (span-text text span)] [_ #f])) -(define (parse-reader-directive-node snapshot spans node next-idx) +(define (parse-reader-directive-node text spans node next-idx) ;; `read-language` is only for `#lang` lines, so `#reader` lines are handled ;; syntactically. The lexer exposes the marker and the following reader name ;; separately; keep the next non-skippable node as the reader text. (match node [(Token-Leaf span) #:when (eq? 'reader-directive (LexerTokenSpan-type span)) - (define-values (reader-nodes _reader-idx) + (define-values (reader-nodes reader-idx) (read-next-non-skippable-nodes/spans spans next-idx 1)) (match reader-nodes [(list reader-node) - (Language-Node - 'reader-directive - (token-node-text snapshot reader-node) - (LexerTokenSpan-start span) - (token-node-end reader-node))] + (Language-Prefix 'reader-directive + (token-node-text text reader-node) + (LexerTokenSpan-start span) + (token-node-end reader-node) + reader-idx)] ['() - (make-language-node 'malformed-reader-directive "" span)])] + (make-language-prefix 'malformed-reader-directive "" span reader-idx)])] [_ #f])) -(define (parse-raw-module-node snapshot node) +(define (parse-raw-module-node text node start-idx) ;; Raw `(module name lang ...)` forms do not go through `read-language` either, ;; so the language position is syntactic. If the first significant child is ;; `module`, keep the third significant child as the language text even when it ;; names an unknown module path; `parse-language` will decide whether it is ;; known. - (match node - [(Token-Tree open-span children _close-span) + (cond + [(Token-List? node) + (define children (token-node-children node)) (define (node-symbol-text node) - (leaf-symbol-text snapshot node)) - + (leaf-symbol-text text node)) (match (read-next-non-skippable-nodes children 3) [(list (app node-symbol-text "module") _mod-id mod-path-node) - (Language-Node - 'raw-module - (token-node-text snapshot mod-path-node) - (LexerTokenSpan-start open-span) - (token-node-end mod-path-node))] + (Language-Prefix 'raw-module + (token-node-text text mod-path-node) + (token-node-start node) + (token-node-end mod-path-node) + start-idx)] [(list (app node-symbol-text "module") _ ...) - (Language-Node - 'malformed-raw-module - "" - (token-node-start node) - (token-node-end node))] + (Language-Prefix 'malformed-raw-module + "" + (token-node-start node) + (token-node-end node) + start-idx)] [_ #f])] - [_ #f])) + [else #f])) (define (find-language-by-text text) (for/or ([language (in-list known-languages)]) @@ -208,12 +212,7 @@ (and (member maybe-suffix (Known-Language-suffixes language)) language)))) -(define/contract (parse-language-node source [idx 0]) - (->* ((or/c string? LexerSnapshot?)) - (exact-nonnegative-integer?) - (or/c Language-Node? #f)) - (define snapshot (source->snapshot source)) - (define spans (LexerSnapshot-tokens snapshot)) +(define (parse-language-prefix-from-spans text spans [idx 0]) (define-values (_skippable-nodes start-idx) (parse-skippable-node spans idx)) (cond @@ -221,21 +220,56 @@ [else (define-values (node next-idx) (parse-token-node spans start-idx)) - (or (parse-lang-directive-node snapshot node) - (parse-reader-directive-node snapshot spans node next-idx) - (parse-raw-module-node snapshot node))])) + (or (parse-lang-directive-node text node next-idx) + (parse-reader-directive-node text spans node next-idx) + (parse-raw-module-node text node start-idx))])) -(define/contract (parse-language source [uri #f]) +(define/contract (parse-language-prefix source [idx 0]) (->* ((or/c string? LexerSnapshot?)) - ((or/c #f string?)) - (or/c Known-Language? 'unrecognized-language #f)) - (define language-node* (parse-language-node source)) + (exact-nonnegative-integer?) + (or/c Language-Prefix? #f)) + (define-values (text spans) + (source->text+spans source)) + (parse-language-prefix-from-spans text spans idx)) + +(define (language-prefix->language language-prefix uri) (cond - [language-node* - (or (find-language-by-text (Language-Node-text language-node*)) + [language-prefix + (or (find-language-by-text (Language-Prefix-text language-prefix)) 'unrecognized-language)] [else (guess-language-by-uri uri)])) +(define/contract (parse-language source [uri #f]) + (->* ((or/c string? LexerSnapshot?)) + ((or/c #f string?)) + (or/c Known-Language? 'unrecognized-language #f)) + (define prefix (parse-language-prefix source)) + (language-prefix->language prefix uri)) + +(struct/contract Language-Info + ([prefix (or/c Language-Prefix? #f)] + [language (or/c Known-Language? 'unrecognized-language #f)] + [body-mode (or/c 'sexp 'non-sexp 'unknown)]) + #:transparent) + +(define/contract (lexer-language-info text spans [uri #f]) + (->* (string? (vectorof LexerTokenSpan?)) + ((or/c #f string?)) + Language-Info?) + (define maybe-prefix (parse-language-prefix-from-spans text spans)) + (define maybe-language (language-prefix->language maybe-prefix uri)) + (define body-mode + (cond + [(and (Known-Language? maybe-language) + (Known-Language-sexp? maybe-language)) + 'sexp] + [(Known-Language? maybe-language) + 'non-sexp] + [else 'unknown])) + (Language-Info maybe-prefix + maybe-language + body-mode)) + (define/contract (sexp-language? source [uri #f]) (->* ((or/c string? LexerSnapshot?)) ((or/c #f string?)) @@ -257,13 +291,20 @@ (and (procedure? maybe-language-info) (maybe-language-info 'drracket:indentation #f)))) -(provide (struct-out Language-Node) +(provide (struct-out Language-Prefix) + language-prefix-source/c (struct-out Known-Language) + Language-Info + Language-Info? + Language-Info-prefix + Language-Info-language + Language-Info-body-mode Known-Language~kw known-languages find-language-by-text - parse-language-node + parse-language-prefix parse-language guess-language-by-uri + lexer-language-info sexp-language? get-indenter) diff --git a/doclib/lexer/scan.rkt b/doclib/lexer/scan.rkt new file mode 100644 index 0000000..ca7db77 --- /dev/null +++ b/doclib/lexer/scan.rkt @@ -0,0 +1,118 @@ +#lang racket/base + +(require "shared.rkt" + racket/contract + racket/match + racket/string + syntax-color/module-lexer + syntax-color/racket-lexer) + +;; Raw syntax-color integration. This module turns source text into normalized +;; token spans and does not know about token trees, snapshots, or language +;; policy. + +(define (lang-directive? txt) + (and (string? txt) + (string-prefix? txt "#lang "))) + +;; Normalize token types to stable project-local names. +(define (normalize-token type text) + (match* (type text) + [('parenthesis (or "(" "[" "{")) + 'open-paren] + [('parenthesis (or ")" "]" "}")) + 'close-paren] + [(_ "'") 'quote] + [(_ "`") 'quasiquote] + [(_ ",") 'unquote] + [(_ "#;") 'sexp-comment] + [(_ "#'") 'syntax-quote] + [(_ "#`") 'syntax-quasiquote] + [(_ "#,@") 'syntax-unquote-splicing] + [(_ "#,") 'syntax-unquote] + [(_ ",@") 'unquote-splicing] + [(_ "#reader") 'reader-directive] + ;; `module-lexer` uses `read-language` to detect lang directives. Correct + ;; lang lines are assigned `other`; incorrect ones are assigned `error`. + [('other (? lang-directive?)) 'lang-directive] + [(_ _) type])) + +;; Racket lexers report 1-based positions. Normalize to zero-based offsets and +;; clamp at zero so synthetic positions do not go negative. +(define (normalize-lexer-pos pos) + (max 0 (sub1 pos))) + +(define (record-lexer-span type start end) + (define normalized-start (normalize-lexer-pos start)) + (define normalized-end (normalize-lexer-pos end)) + (make-lexer-span normalized-start normalized-end type)) + +(define (lexer-wrap lexer) + (define (eof-or-list txt type paren? start end) + (if (eof-object? txt) + eof + (list txt type paren? start end))) + + (cond + [(procedure? lexer) + (lambda (in) + (define-values (txt type paren? start end) + (lexer in)) + (eof-or-list txt type paren? start end))] + [(pair? lexer) + (define lexer-proc (car lexer)) + (define mode (cdr lexer)) + (lambda (in) + (define-values (txt type paren? start end _backup next-mode) + (lexer-proc in 0 mode)) + ;; Preserve the updated lexer mode so the next call continues where + ;; this one left off. + (set! mode next-mode) + (eof-or-list txt type paren? start end))])) + +;; `module-lexer` returns the lexer to use on the remaining input as one of: +;; - a procedure (simple lexers), +;; - a `(procedure . mode)` pair (stateful lexers), or +;; - a non-lexer value such as `#f` (meaning “no specific lexer available”). +;; For `#lang` modules the result is a language-specific lexer (e.g. Rhombus). +;; For `#reader` headers the result is currently a non-lexer value because +;; `read-language` (which `module-lexer` relies on) does not recognize +;; `#reader`, so we fall back to `racket-lexer` even when the reader names +;; a non-sexp language. +(define (module-lexer->lexer lexer) + (if (or (procedure? lexer) (pair? lexer)) + lexer + racket-lexer)) + +(define (get-initial-lexer-state in) + (define-values (txt type paren? start end _backup lexer) + (module-lexer in 0 #f)) + (values txt type paren? start end (module-lexer->lexer lexer))) + +(define/contract (text->lexer-token-spans text) + (-> string? (vectorof LexerTokenSpan?)) + (define in (open-input-string text)) + (port-count-lines! in) + (define-values (initial-txt initial-type _initial-paren? initial-start initial-end lexer) + (get-initial-lexer-state in)) + ;; The initial token comes from `module-lexer`; subsequent tokens come from + ;; the language-specific lexer selected above. + (define initial-span + (and (not (eof-object? initial-txt)) + (record-lexer-span (normalize-token initial-type initial-txt) + initial-start + initial-end))) + (define rest-token-spans + (for*/list ([lst (in-port (lexer-wrap lexer) in)] + [span (in-value + (match lst + [(list txt type _paren? start end) + (record-lexer-span (normalize-token type txt) start end)]))] + #:when span) + span)) + (list->vector + (if initial-span + (cons initial-span rest-token-spans) + rest-token-spans))) + +(provide text->lexer-token-spans) diff --git a/doclib/lexer/shared.rkt b/doclib/lexer/shared.rkt index beaa33e..359de52 100644 --- a/doclib/lexer/shared.rkt +++ b/doclib/lexer/shared.rkt @@ -1,8 +1,10 @@ #lang racket/base -(require racket/contract - racket/match - racket/string) +(require racket/contract) + +;; Shared lexer data shapes. Keep this module independent from scanning and +;; token-tree parsing so the rest of the lexer stack can depend on common data +;; without forming cycles. (struct/contract LexerTokenSpan ([start exact-nonnegative-integer?] @@ -10,43 +12,21 @@ [type symbol?]) #:transparent) +(struct/contract LexerSnapshot + ([text string?] + [tokens (vectorof LexerTokenSpan?)]) + #:transparent) + (define (make-lexer-span start end type) (and (< start end) (LexerTokenSpan start end type))) -(define (lang-directive? txt) - (and (string? txt) - (string-prefix? txt "#lang "))) - -;; Normalize tokens types to more meaningful. -(define (normalize-token type text) - (match* (type text) - [('parenthesis (or "(" "[" "{")) - 'open-paren] - [('parenthesis (or ")" "]" "}")) - 'close-paren] - [(_ "'") 'quote] - [(_ "`") 'quasiquote] - [(_ ",") 'unquote] - [(_ "#;") 'sexp-comment] - [(_ "#'") 'syntax-quote] - [(_ "#`") 'syntax-quasiquote] - [(_ "#,@") 'syntax-unquote-splicing] - [(_ "#,") 'syntax-unquote] - [(_ ",@") 'unquote-splicing] - [(_ "#reader") 'reader-directive] - ;; lexer uses `read-language` to detect lang directives. - ;; Correct lang line are assigned `other` type, incorrect ones are assigned `error` type. - ;; We only handle correct ones here. - [('other (? lang-directive?)) 'lang-directive] - [(_ _) type])) - (define (span-at spans idx) (and (<= 0 idx) (< idx (vector-length spans)) (vector-ref spans idx))) (provide (struct-out LexerTokenSpan) + (struct-out LexerSnapshot) make-lexer-span - normalize-token span-at) diff --git a/doclib/service/diagnostic.rkt b/doclib/service/diagnostic.rkt index 4d179dc..6e9a4aa 100644 --- a/doclib/service/diagnostic.rkt +++ b/doclib/service/diagnostic.rkt @@ -100,17 +100,17 @@ ;; Return a diagnostic for a missing or unrecognized source language declaration. (define (language-diagnostic doc-text) (define text (send doc-text get-text)) - (define maybe-language-node (parse-language-node text)) + (define maybe-language-prefix (parse-language-prefix text)) (cond - [(not maybe-language-node) + [(not maybe-language-prefix) (language-error-diag (first-line-range doc-text) "Missing language declaration. Add a `#lang` line, `#reader`, or `(module ... ...)` form.")] - [(find-language-by-text (Language-Node-text maybe-language-node)) #f] + [(find-language-by-text (Language-Prefix-text maybe-language-prefix)) #f] [else (language-error-diag - (language-node-range doc-text maybe-language-node) - (unrecognized-language-message maybe-language-node))])) + (language-prefix-range doc-text maybe-language-prefix) + (unrecognized-language-message maybe-language-prefix))])) (define (language-error-diag range message) (Diagnostic #:range range @@ -135,14 +135,14 @@ (Range #:start (abs-pos->Pos doc-text start) #:end (abs-pos->Pos doc-text end))) -(define (language-node-range doc-text language-node) +(define (language-prefix-range doc-text language-prefix) (nonempty-diagnostic-range doc-text - (Range #:start (abs-pos->Pos doc-text (Language-Node-start language-node)) - #:end (abs-pos->Pos doc-text (Language-Node-end language-node))))) + (Range #:start (abs-pos->Pos doc-text (Language-Prefix-start language-prefix)) + #:end (abs-pos->Pos doc-text (Language-Prefix-end language-prefix))))) -(define (unrecognized-language-message language-node) - (define language-text (Language-Node-text language-node)) +(define (unrecognized-language-message language-prefix) + (define language-text (Language-Prefix-text language-prefix)) (cond [(not (string=? "" language-text)) (format diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt index 49b786f..b86e60e 100644 --- a/tests/lib/doc-lang-test.rkt +++ b/tests/lib/doc-lang-test.rkt @@ -5,8 +5,8 @@ "../../doclib/doc-lang.rkt" "../../doclib/lexer.rkt") - (define (parse-node text) - (parse-language-node (build-lexer-snapshot text))) + (define (parse-prefix text) + (parse-language-prefix (build-lexer-snapshot text))) (define (parse-known-language text [uri #f]) (parse-language (build-lexer-snapshot text) uri)) @@ -16,8 +16,8 @@ (and (Known-Language? language) (Known-Language-name language))) - (define (node source text end) - (Language-Node source text 0 end)) + (define (prefix source text end body-start-idx) + (Language-Prefix source text 0 end body-start-idx)) (test-case "Known-Language has a keyword constructor" @@ -29,108 +29,123 @@ (Known-Language 'demo #t '("demo") #px"^demo$"))) (test-case - "parse-language-node recognizes an ordinary #lang line" + "parse-language-prefix recognizes an ordinary #lang line" (check-equal? - (parse-node "#lang racket/base\n(define x 1)\n") - (node 'lang-directive "racket/base" (string-length "#lang racket/base")))) + (parse-prefix "#lang racket/base\n(define x 1)\n") + (prefix 'lang-directive "racket/base" (string-length "#lang racket/base") 1))) (test-case - "parse-language-node recognizes #lang reader wrappers" + "parse-language-prefix recognizes #lang reader wrappers" (check-equal? - (parse-node "#lang reader syntax/module-reader\nracket/base\n") - (node 'reader-lang - "syntax/module-reader" - (string-length "#lang reader syntax/module-reader")))) + (parse-prefix "#lang reader syntax/module-reader\nracket/base\n") + (prefix 'reader-lang + "syntax/module-reader" + (string-length "#lang reader syntax/module-reader") + 1))) (test-case - "parse-language-node keeps the full payload after #lang reader" + "parse-language-prefix keeps the full payload after #lang reader" (check-equal? - (parse-node "#lang reader \"literal.rkt\"\nhello\n") - (node 'reader-lang - "\"literal.rkt\"" - (string-length "#lang reader \"literal.rkt\""))) + (parse-prefix "#lang reader \"literal.rkt\"\nhello\n") + (prefix 'reader-lang + "\"literal.rkt\"" + (string-length "#lang reader \"literal.rkt\"") + 1)) (check-equal? - (parse-node + (parse-prefix "#lang reader (submod syntax/module-reader reader)\n1\n") - (node 'reader-lang - "(submod syntax/module-reader reader)" - (string-length - "#lang reader (submod syntax/module-reader reader)"))) + (prefix 'reader-lang + "(submod syntax/module-reader reader)" + (string-length + "#lang reader (submod syntax/module-reader reader)") + 1)) (check-equal? - (parse-node "#lang reader (foo)\n1\n") - (node 'reader-lang - "(foo)" - (string-length "#lang reader (foo)")))) + (parse-prefix "#lang reader (foo)\n1\n") + (prefix 'reader-lang + "(foo)" + (string-length "#lang reader (foo)") + 1))) (test-case - "parse-language-node recognizes #reader directives" + "parse-language-prefix recognizes #reader directives" (check-equal? - (parse-node "#reader scribble/reader\n@title{demo}\n") - (node 'reader-directive - "scribble/reader" - (string-length "#reader scribble/reader"))) + (parse-prefix "#reader scribble/reader\n@title{demo}\n") + (prefix 'reader-directive + "scribble/reader" + (string-length "#reader scribble/reader") + 3)) (check-equal? - (parse-node "#reader (reader demo)\nbody\n") - (node 'reader-directive - "(reader demo)" - (string-length "#reader (reader demo)")))) + (parse-prefix "#reader (reader demo)\nbody\n") + (prefix 'reader-directive + "(reader demo)" + (string-length "#reader (reader demo)") + 7))) (test-case - "parse-language-node recognizes raw modules" + "parse-language-prefix recognizes raw modules" (check-equal? - (parse-node "(module demo typed/racket/base (define x 1))\n") - (node 'raw-module - "typed/racket/base" - (string-length "(module demo typed/racket/base"))) + (parse-prefix "(module demo typed/racket/base (define x 1))\n") + (prefix 'raw-module + "typed/racket/base" + (string-length "(module demo typed/racket/base") + 0)) (check-equal? - (parse-node "(module demo (lib \"racket/base\") (define x 1))\n") - (node 'raw-module - "(lib \"racket/base\")" - (string-length "(module demo (lib \"racket/base\")"))) + (parse-prefix "(module demo (lib \"racket/base\") (define x 1))\n") + (prefix 'raw-module + "(lib \"racket/base\")" + (string-length "(module demo (lib \"racket/base\")") + 0)) (check-equal? - (parse-node "(module demo \"literal.rkt\" (define x 1))\n") - (node 'raw-module - "\"literal.rkt\"" - (string-length "(module demo \"literal.rkt\"")))) + (parse-prefix "(module demo \"literal.rkt\" (define x 1))\n") + (prefix 'raw-module + "\"literal.rkt\"" + (string-length "(module demo \"literal.rkt\"") + 0))) (test-case - "parse-language-node skips leading comments and sexp comments" + "parse-language-prefix skips leading comments and sexp comments" (check-equal? - (parse-node "; preamble\n#; (define ignored 1)\n#lang rhombus\nfun f(): 1\n") - (Language-Node 'lang-directive "rhombus" 33 46))) + (parse-prefix "; preamble\n#; (define ignored 1)\n#lang rhombus\nfun f(): 1\n") + (Language-Prefix 'lang-directive "rhombus" 33 46 13))) (test-case - "parse-language-node reports present but unrecognized selectors" - (check-equal? (parse-node "#lang \n(define x 1)\n") - (node 'malformed-lang-directive "" (string-length "#lang "))) - (check-equal? (parse-node "#lang reader\n(define x 1)\n") - (node 'malformed-lang-directive "" - (string-length "#lang reader\n(define x 1)"))) - (check-equal? (parse-node "#lang not-a-real-language\n1\n") - (node 'lang-directive - "not-a-real-language" - (string-length "#lang not-a-real-language"))) - (check-equal? (parse-node "#reader\n") - (node 'malformed-reader-directive "" (string-length "#reader"))) - (check-equal? (parse-node "#reader does/not/exist\n") - (node 'reader-directive - "does/not/exist" - (string-length "#reader does/not/exist"))) - (check-equal? (parse-node "(module demo does/not/exist (define x 1))\n") - (node 'raw-module - "does/not/exist" - (string-length "(module demo does/not/exist"))) - (check-equal? (parse-node "(module demo 1 (define x 1))\n") - (node 'raw-module - "1" - (string-length "(module demo 1"))) - (check-equal? (parse-node "(module demo)\n") - (Language-Node + "parse-language-prefix reports present but unrecognized selectors" + (check-equal? (parse-prefix "#lang \n(define x 1)\n") + (prefix 'malformed-lang-directive "" (string-length "#lang ") 1)) + (check-equal? (parse-prefix "#lang reader\n(define x 1)\n") + (prefix 'malformed-lang-directive "" + (string-length "#lang reader\n(define x 1)") + 1)) + (check-equal? (parse-prefix "#lang not-a-real-language\n1\n") + (prefix 'lang-directive + "not-a-real-language" + (string-length "#lang not-a-real-language") + 1)) + (check-equal? (parse-prefix "#reader\n") + (prefix 'malformed-reader-directive "" (string-length "#reader") 2)) + (check-equal? (parse-prefix "#reader does/not/exist\n") + (prefix 'reader-directive + "does/not/exist" + (string-length "#reader does/not/exist") + 3)) + (check-equal? (parse-prefix "(module demo does/not/exist (define x 1))\n") + (prefix 'raw-module + "does/not/exist" + (string-length "(module demo does/not/exist") + 0)) + (check-equal? (parse-prefix "(module demo 1 (define x 1))\n") + (prefix 'raw-module + "1" + (string-length "(module demo 1") + 0)) + (check-equal? (parse-prefix "(module demo)\n") + (Language-Prefix 'malformed-raw-module "" 0 - (string-length "(module demo)"))) - (check-false (parse-node "(define x 1)\n(module demo racket/base x)\n"))) + (string-length "(module demo)") + 0)) + (check-false (parse-prefix "(define x 1)\n(module demo racket/base x)\n"))) (test-case "parse-language matches explicit known language families" From b4fad021efb0017aeba95e2626fcea88444cbf9d Mon Sep 17 00:00:00 2001 From: 6cdh Date: Mon, 11 May 2026 12:02:58 +0800 Subject: [PATCH 10/17] Add lexer state and token tree queries --- common/interfaces.rkt | 16 ++- doclib/lexer.rkt | 266 ++++++++++++++++-------------------- doclib/lexer/token-tree.rkt | 102 ++++++++++---- doclib/lexer/tree-query.rkt | 107 +++++++++++++++ tests/lib/lexer-test.rkt | 230 +++++++++++++++++++++++++++++-- 5 files changed, 530 insertions(+), 191 deletions(-) create mode 100644 doclib/lexer/tree-query.rkt diff --git a/common/interfaces.rkt b/common/interfaces.rkt index 4ff5a17..3c40ee0 100644 --- a/common/interfaces.rkt +++ b/common/interfaces.rkt @@ -14,7 +14,8 @@ racket/match "json-util.rkt") -(provide (json-type-out Pos) +(provide (struct-out CharRange) + (json-type-out Pos) (json-type-out Range) char-range-intersect? (json-type-out TextEdit) @@ -252,6 +253,13 @@ [trim-final-newlines (optional boolean?) #:json trimFinalNewlines] [key (or/c false/c (optional/c hash?))]) +;; Character-offset range. Distinct from the protocol-level `Range` +;; (which uses line/char positions); this one uses zero-based absolute +;; character offsets. +(struct CharRange + (start end) + #:transparent) + ;; Public query result for cached lexer tokens. Positions are zero-based ;; absolute character offsets; callers still need to convert them to line / ;; character pairs for LSP positions. @@ -267,7 +275,8 @@ [function "function"] [string "string"] [number "number"] - [regexp "regexp"]) + [regexp "regexp"] + [comment "comment"]) (define-json-enum SemanticTokenModifier [definition "definition"]) @@ -287,7 +296,8 @@ SemanticTokenType-function SemanticTokenType-string SemanticTokenType-number - SemanticTokenType-regexp)) + SemanticTokenType-regexp + SemanticTokenType-comment)) ;; The order of this list is irrelevant, similar to *semantic-token-types*. (define *semantic-token-modifiers* diff --git a/doclib/lexer.rkt b/doclib/lexer.rkt index c3425a9..8a75ecd 100644 --- a/doclib/lexer.rkt +++ b/doclib/lexer.rkt @@ -1,12 +1,14 @@ #lang racket/base (require "../common/interfaces.rkt" + "doc-lang.rkt" + "lazy-cache.rkt" + "lexer/scan.rkt" "lexer/shared.rkt" "lexer/token-tree.rkt" + "lexer/tree-query.rkt" racket/contract - racket/match - syntax-color/module-lexer - syntax-color/racket-lexer) + racket/match) ;; Upstream lexer type docs: ;; https://docs.racket-lang.org/syntax-color/Racket_Lexer.html @@ -35,32 +37,15 @@ ;; that language's `color-lexer`; when a colorer reports an attribute hash it ;; extracts the `'type` field. ;; -;; This module normalizes token kinds so callers see stable shapes across +;; The scan layer normalizes token kinds so callers see stable shapes across ;; valid and invalid inputs: ;; - 'lang-directive: a leading `#lang` ;; - 'reader-directive: a leading `#reader` ;; - quote-family and syntax quote-family prefixes, plus `#;` ;; - open-paren/close-paren direction for the internal span cache ;; -;; This module caches the full lexer stream so callers can distinguish any -;; token class at a given position while reconstructing public token strings on -;; demand. - -(struct/contract LexerSnapshot - ([text string?] - [tokens (vectorof LexerTokenSpan?)]) - #:transparent) - -;; Racket lexers report 1-based positions. Normalize to zero-based offsets and -;; clamp at zero so synthetic positions do not go negative. -(define (normalize-lexer-pos pos) - (max 0 (sub1 pos))) - -;; Record one lexer span from the lexer stream. -(define (record-lexer-span type start end) - (define normalized-start (normalize-lexer-pos start)) - (define normalized-end (normalize-lexer-pos end)) - (make-lexer-span normalized-start normalized-end type)) +;; This module is the public lexer facade. It builds snapshots from normalized +;; token spans, attaches a token forest, and exposes position-oriented queries. (define/contract (lexer-snapshot-span->entry snapshot span) (-> LexerSnapshot? LexerTokenSpan? LexerEntry?) @@ -71,10 +56,13 @@ (LexerTokenSpan-end span)) (LexerTokenSpan-type span))) -;; Binary search returns the first token whose end is strictly after `pos`. -;; That token is only a candidate, because spans may have gaps, so the caller -;; still checks the start bound to confirm `pos` is inside the span. -(define (find-first-token-ending-after tokens pos) +(define (lexer-token-span-contains-pos? span pos) + (and (<= (LexerTokenSpan-start span) pos) + (< pos (LexerTokenSpan-end span)))) + +;; Find the token at `pos`, or the next token after `pos` when `pos` falls +;; between token spans. Returns #f when `pos` is after the last token. +(define (find-token-index-at-or-after tokens pos) (define token-count (vector-length tokens)) (let loop ([low 0] [high token-count]) @@ -88,45 +76,54 @@ (loop (add1 mid) high) (loop low mid))]))) +(define (find-token-index-at tokens pos) + (define idx (find-token-index-at-or-after tokens pos)) + (and idx + (let ([span (vector-ref tokens idx)]) + (and (lexer-token-span-contains-pos? span pos) idx)))) + (define (lookup-lexer-entry snapshot pos) (define tokens (LexerSnapshot-tokens snapshot)) - (define idx (find-first-token-ending-after tokens pos)) + (define idx (find-token-index-at tokens pos)) (and idx - (let ([span (vector-ref tokens idx)]) - (and (<= (LexerTokenSpan-start span) pos) - (lexer-snapshot-span->entry snapshot span))))) + (lexer-snapshot-span->entry snapshot (vector-ref tokens idx)))) ;; Find the token at `pos`, or the last token before `pos` when `pos` falls -;; between token spans. +;; between token spans. Returns #f when `pos` is before the first token. (define (find-token-index-at-or-before tokens pos) (define token-count (vector-length tokens)) - (define idx (find-first-token-ending-after tokens pos)) + (define idx (find-token-index-at-or-after tokens pos)) (cond [(not idx) (and (positive? token-count) (sub1 token-count))] [else (define span (vector-ref tokens idx)) - (if (<= (LexerTokenSpan-start span) pos) - idx - (sub1 idx))])) - -(define (lexer-layout-token? type) - (memq type '(white-space comment sexp-comment))) - -(define (scan-enclosing-paren snapshot tokens idx depth) - (cond - [(< idx 0) #f] - [else - (define span (vector-ref tokens idx)) - (match (LexerTokenSpan-type span) - ['close-paren - (scan-enclosing-paren snapshot tokens (sub1 idx) (add1 depth))] - ['open-paren - (if (positive? depth) - (scan-enclosing-paren snapshot tokens (sub1 idx) (sub1 depth)) - (LexerTokenSpan-start span))] - [_ - (scan-enclosing-paren snapshot tokens (sub1 idx) depth)])])) + (cond + [(lexer-token-span-contains-pos? span pos) idx] + [(zero? idx) #f] + [else (sub1 idx)])])) + +;; Build a token forest from token spans. Uses language info to decide what +;; portion of the spans to parse: for non-sexp languages only the prefix is +;; parsed; for sexp languages, the body starting at body-start-idx is parsed. +(define (build-snapshot-token-forest text uri spans) + (define info (lexer-language-info text spans uri)) + (define total (vector-length spans)) + (define body-start-idx + (cond [(Language-Info-prefix info) + => Language-Prefix-body-start-idx] + [else 0])) + (define-values (start end) + (cond + [(eq? 'non-sexp (Language-Info-body-mode info)) + (values 0 body-start-idx)] + [else + (values (if (and (< body-start-idx total) + (span-at spans body-start-idx)) + body-start-idx + 0) + total)])) + (parse-token-forest spans start end)) (define/contract (in-lexer-snapshot snapshot) (-> LexerSnapshot? sequence?) @@ -149,101 +146,7 @@ (for ([entry (in-lexer-snapshot snapshot)]) (proc entry))) -(define/contract (lexer-snapshot-enclosing-paren-start snapshot pos) - (-> LexerSnapshot? exact-nonnegative-integer? (or/c exact-nonnegative-integer? #f)) - (define tokens (LexerSnapshot-tokens snapshot)) - (define token-count (vector-length tokens)) - (cond - [(or (zero? token-count) - (>= pos (string-length (LexerSnapshot-text snapshot)))) - #f] - [else - (define idx (find-token-index-at-or-before tokens pos)) - (scan-enclosing-paren snapshot tokens idx 0)])) - -(define/contract (lexer-snapshot-next-symbol-start snapshot pos) - (-> LexerSnapshot? exact-nonnegative-integer? (or/c exact-nonnegative-integer? #f)) - (define tokens (LexerSnapshot-tokens snapshot)) - (let loop ([idx (find-first-token-ending-after tokens pos)]) - (cond - [(not idx) #f] - [(>= idx (vector-length tokens)) #f] - [else - (define span (vector-ref tokens idx)) - (match (LexerTokenSpan-type span) - [(? lexer-layout-token?) - (loop (add1 idx))] - ['symbol - (LexerTokenSpan-start span)] - [_ #f])]))) - -(define (lexer-wrap lexer) - (define (eof-or-list txt type paren? start end) - (if (eof-object? txt) - eof - (list txt type paren? start end))) - - (cond - [(procedure? lexer) - (lambda (in) - (define-values (txt type paren? start end) - (lexer in)) - (eof-or-list txt type paren? start end))] - [(pair? lexer) - (define lexer-proc (car lexer)) - (define mode (cdr lexer)) - (lambda (in) - (define-values (txt type paren? start end _backup next-mode) - (lexer-proc in 0 mode)) - ;; Preserve the updated lexer mode so the next call continues where - ;; this one left off. - (set! mode next-mode) - (eof-or-list txt type paren? start end))])) - -;; `module-lexer` can return a procedure, a `(procedure . mode)` pair, or a -;; sentinel value. That is how language-specific lexers are surfaced for -;; `#lang` modules such as Rhombus. For the pair case, `car` is the lexer -;; procedure and `cdr` is the lexer-specific state to pass back on the next -;; call. -(define (module-lexer->lexer lexer) - (if (or (procedure? lexer) (pair? lexer)) - lexer - racket-lexer)) - -(define (get-initial-lexer-state in) - (define-values (txt type paren? start end _backup lexer) - (module-lexer in 0 #f)) - (values txt type paren? start end (module-lexer->lexer lexer))) - -(define/contract (build-lexer-snapshot text) - (-> string? LexerSnapshot?) - ;; Count lines before lexing so the lexer reports stable source locations for - ;; the entire document snapshot. - (define in (open-input-string text)) - (port-count-lines! in) - (define-values (initial-txt initial-type _initial-paren? initial-start initial-end lexer) - (get-initial-lexer-state in)) - ;; The initial token comes from `module-lexer`; subsequent tokens come from - ;; the language-specific lexer selected above. - (define initial-span - (and (not (eof-object? initial-txt)) - (record-lexer-span (normalize-token initial-type initial-txt) - initial-start - initial-end))) - (define rest-token-spans - (for*/list ([lst (in-port (lexer-wrap lexer) in)] - [span (in-value - (match lst - [(list txt type _paren? start end) - (record-lexer-span (normalize-token type txt) start end)]))] - #:when span) - span)) - (define token-spans - (if initial-span - (cons initial-span rest-token-spans) - rest-token-spans)) - - (LexerSnapshot text (list->vector token-spans))) +;; Flat token queries — these never need a token forest. (define/contract (lexer-snapshot-token-at snapshot pos) (-> LexerSnapshot? exact-nonnegative-integer? (or/c LexerEntry? #f)) @@ -256,19 +159,78 @@ (eq? (LexerEntry-type entry) 'symbol) entry)) +;; Structural tree queries — these require a token forest. +;; Callers should ensure the document is in a sexp-compatible body mode. + +(define/contract (build-lexer-snapshot text [uri #f]) + (->* (string?) ((or/c #f string?)) LexerSnapshot?) + (define token-span-vector (text->lexer-token-spans text)) + (LexerSnapshot text token-span-vector)) + +;; LexerState groups the flat snapshot, language metadata, and a lazy body-forest +;; cache. Documents keep one LexerState instead of separate caches for snapshot, +;; language, and forest. The forest covers whatever portion of the token spans is +;; relevant for the language's body mode (full file for sexp/unknown, header-only +;; for non-sexp). +(struct/contract LexerState + ([snapshot LexerSnapshot?] + [language-info Language-Info?] + [body-forest-cache (lazy-cache-of Token-Forest?)]) + #:transparent) + +(define (build-lexer-state text uri) + (define snapshot (build-lexer-snapshot text uri)) + (define info (lexer-language-info (LexerSnapshot-text snapshot) + (LexerSnapshot-tokens snapshot) + uri)) + (LexerState snapshot info (make-lazy-cache))) + +(define (lexer-state-body-forest state text uri) + (call-with-lazy-cache! + (LexerState-body-forest-cache state) + (lambda () + (build-snapshot-token-forest text + uri + (LexerSnapshot-tokens (LexerState-snapshot state)))))) + (provide (struct-out LexerTokenSpan) (struct-out LexerSnapshot) LexerSnapshot? token-node? sexp-comment-node? + token-node-children + token-node-span + parse-token-forest + token-forest-flattened-nodes + token-forest-node-path + token-node-parent/path + token-forest-ancestors-at-pos + token-forest-deepest-enclosing-list + token-forest-form-head + token-forest-sexp-comment-spans (struct-out Token-Leaf) - (struct-out Token-Tree) + (struct-out Token-List) (struct-out Token-Prefix-Tree) + (struct-out Token-Forest) build-lexer-snapshot + build-lexer-state + build-snapshot-token-forest + LexerState? + LexerState-snapshot + LexerState-language-info + lexer-state-body-forest + lexer-language-info + Language-Info + Language-Info? + Language-Info-prefix + Language-Info-language + Language-Info-body-mode lexer-snapshot-span->entry + lexer-token-span-contains-pos? in-lexer-snapshot for-each-lexer-snapshot-entry - lexer-snapshot-enclosing-paren-start - lexer-snapshot-next-symbol-start + find-token-index-at + find-token-index-at-or-before + find-token-index-at-or-after lexer-snapshot-token-at lexer-snapshot-symbol-at) diff --git a/doclib/lexer/token-tree.rkt b/doclib/lexer/token-tree.rkt index 6acc6a9..e4f8c85 100644 --- a/doclib/lexer/token-tree.rkt +++ b/doclib/lexer/token-tree.rkt @@ -1,22 +1,29 @@ #lang racket/base (require "shared.rkt" + "../../common/interfaces.rkt" racket/list racket/match) +;; Token-tree parsing over already-normalized token spans. This module does not +;; know how spans were produced and does not know about document snapshots. +;; Structural queries live in tree-query.rkt. + ;; Token-Leaf: a single token span, representing a leaf in the token tree. (struct Token-Leaf (span) #:transparent) -;; Token-Tree: a delimited form, with an open parenthesis span, -;; a list of child nodes ,and an optional close parenthesis span. -(struct Token-Tree (open-span children close-span) #:transparent) +;; Token-List: a delimited form, with an open parenthesis span, a list of child +;; nodes, an optional close parenthesis span, and its full end +;; position. +(struct Token-List (open-span children close-span end) #:transparent) ;; Token-Prefix-Tree: a prefix token (quote-family, syntax quote-family, ;; or `#;`) plus the skippable trivia after it and an -;; optional operand node. -(struct Token-Prefix-Tree (prefix-span skippable-nodes child) #:transparent) +;; optional operand node, plus its full end position. +(struct Token-Prefix-Tree (prefix-span skippable-nodes child end) #:transparent) +(struct Token-Forest (nodes) #:transparent) (define (token-node? value) (or (Token-Leaf? value) - (Token-Tree? value) + (Token-List? value) (Token-Prefix-Tree? value))) (define (sexp-comment-node? value) @@ -24,6 +31,15 @@ (eq? 'sexp-comment (LexerTokenSpan-type (Token-Prefix-Tree-prefix-span value))))) +(define (token-node-children node) + (match node + [(Token-Leaf _span) '()] + [(Token-List _open-span children _close-span _end) children] + [(Token-Prefix-Tree _prefix-span skippable-nodes child _end) + (if child + (append skippable-nodes (list child)) + skippable-nodes)])) + (define (skippable-span? span) (memq (LexerTokenSpan-type span) '(white-space comment))) @@ -32,6 +48,9 @@ (skippable-span? (Token-Leaf-span node))) (sexp-comment-node? node)))) +(define (token-leaf-type? leaf type) + (eq? type (LexerTokenSpan-type (Token-Leaf-span leaf)))) + ;; Return up to `n` meaningful nodes from an already-built token tree, ignoring ;; whitespace, ordinary comments, and complete `#;` sexp-comment nodes. (define (read-next-non-skippable-nodes nodes n) @@ -69,23 +88,30 @@ (define (token-node-start node) (match node [(Token-Leaf span) (LexerTokenSpan-start span)] - [(Token-Tree open-span _children _close-span) + [(Token-List open-span _children _close-span _end) (LexerTokenSpan-start open-span)] - [(Token-Prefix-Tree prefix-span _skippable-nodes _child) + [(Token-Prefix-Tree prefix-span _skippable-nodes _child _end) (LexerTokenSpan-start prefix-span)])) (define (token-node-end node) (match node [(Token-Leaf span) (LexerTokenSpan-end span)] - [(Token-Tree open-span children close-span) - (cond - [close-span (LexerTokenSpan-end close-span)] - [(null? children) (LexerTokenSpan-end open-span)] - [else (token-node-end (last children))])] - [(Token-Prefix-Tree prefix-span _skippable-nodes child) - (if child - (token-node-end child) - (LexerTokenSpan-end prefix-span))])) + [(Token-List _open-span _children _close-span end) end] + [(Token-Prefix-Tree _prefix-span _skippable-nodes _child end) end])) + +(define (token-node-span node) + (CharRange (token-node-start node) (token-node-end node))) + +(define (parse-token-forest spans [start-idx 0] [end-idx (vector-length spans)]) + (let loop ([idx start-idx] + [nodes '()]) + (cond + [(>= idx end-idx) + (Token-Forest (reverse nodes))] + [else + (define-values (node next-idx) + (parse-token-node spans idx)) + (loop next-idx (cons node nodes))]))) ;; Skip over whitespaces and comments, accumulating them into `nodes` so they can be ;; preserved in the tree if needed. @@ -110,20 +136,44 @@ (parse-skippable-node spans (add1 idx))) (match (span-at spans next-idx) [#f - (values (Token-Prefix-Tree prefix-span skippable-nodes #f) next-idx)] + (define end + (if (pair? skippable-nodes) + (token-node-end (last skippable-nodes)) + (LexerTokenSpan-end prefix-span))) + (values (Token-Prefix-Tree prefix-span + skippable-nodes + #f + end) + next-idx)] [_ (define-values (child child-idx) (parse-token-node spans next-idx)) - (values (Token-Prefix-Tree prefix-span skippable-nodes child) child-idx)])) + (values (Token-Prefix-Tree prefix-span + skippable-nodes + child + (token-node-end child)) + child-idx)])) ;; Parse a list form, recursively parsing its children until the closing parenthesis is found. (define (parse-list-node spans idx open-span children) (define maybe-span (span-at spans idx)) (match* (maybe-span (and maybe-span (LexerTokenSpan-type maybe-span))) [(#f #f) - (values (Token-Tree open-span (reverse children) #f) idx)] + (define list-end + (if (null? children) + (LexerTokenSpan-end open-span) + (token-node-end (car children)))) + (values (Token-List open-span + (reverse children) + #f + list-end) + idx)] [(close-span 'close-paren) - (values (Token-Tree open-span (reverse children) close-span) (add1 idx))] + (values (Token-List open-span + (reverse children) + close-span + (LexerTokenSpan-end close-span)) + (add1 idx))] [(_ _) (define-values (child child-idx) (parse-token-node spans idx)) @@ -149,12 +199,18 @@ (provide token-node? sexp-comment-node? + non-skippable-node? + token-leaf-type? + token-node-children read-next-non-skippable-nodes read-next-non-skippable-nodes/spans token-node-start token-node-end + token-node-span + parse-token-forest parse-skippable-node parse-token-node (struct-out Token-Leaf) - (struct-out Token-Tree) - (struct-out Token-Prefix-Tree)) + (struct-out Token-List) + (struct-out Token-Prefix-Tree) + (struct-out Token-Forest)) diff --git a/doclib/lexer/tree-query.rkt b/doclib/lexer/tree-query.rkt new file mode 100644 index 0000000..9effa51 --- /dev/null +++ b/doclib/lexer/tree-query.rkt @@ -0,0 +1,107 @@ +#lang racket/base + +(require "shared.rkt" + "token-tree.rkt") + +;; Structural queries over a Token-Forest. This module depends on the node +;; shapes from token-tree.rkt but does not know how forests were produced. + +;; Return a flat list of all nodes in the forest in pre-order (parents +;; before children, depth-first). +(define (token-forest-flattened-nodes forest) + (define nodes '()) + + (define (walk node) + (set! nodes (cons node nodes)) + (for-each walk (token-node-children node))) + + (for-each walk (Token-Forest-nodes forest)) + (reverse nodes)) + +;; True when `pos` is inside `node`'s span (inclusive start, exclusive end). +(define (node-contains-pos? node pos) + (and (<= (token-node-start node) pos) + (< pos (token-node-end node)))) + +;; Return the ancestors of the innermost node at `pos`, from node to root. +;; The first element is the node itself, the last is the root. Returns #f +;; if pos is outside all nodes. +(define (token-forest-ancestors-at-pos forest pos) + (define (search-node node path) + (define next + (for/first ([child (in-list (token-node-children node))] + #:when (node-contains-pos? child pos)) + child)) + (if next + (search-node next (cons node path)) + (cons node path))) + (for/first ([node (in-list (Token-Forest-nodes forest))] + #:when (node-contains-pos? node pos)) + (search-node node '()))) + +;; Search the forest for a specific node `target` (compared via eq?) and +;; return the list of nodes from root to `target` inclusive, or #f if not +;; found. +(define (token-forest-node-path forest target) + (define ancestors (token-forest-ancestors-at-pos forest (token-node-start target))) + (and ancestors (memq target ancestors))) + +;; Find the parent and full path of `target`. +;; Returns two values: (parent path) or (#f path) for a root, or (#f #f) +;; if `target` is not in `forest`. +(define (token-node-parent/path forest target) + (define path (token-forest-node-path forest target)) + (cond + [(and path (pair? (cdr path))) + (values (cadr path) path)] + [path + (values #f path)] + [else + (values #f #f)])) + +;; Find the innermost Token-List that contains `pos`. +;; Example: for the text "(define (f x) (+ x 1))", at a position inside "x" +;; the innermost list is "(f x)". +(define (token-forest-deepest-enclosing-list forest pos) + (define ancestors (token-forest-ancestors-at-pos forest pos)) + (and ancestors + (for/first ([node (in-list ancestors)] + #:when (Token-List? node)) + node))) + +;; Within the deepest list enclosing `pos`, find the first child that is a +;; non-skippable symbol Token-Leaf — i.e., the function/macro/operator +;; name in a form like `(define x 1)`. Returns the LexerTokenSpan or #f. +(define (token-forest-form-head forest pos) + (define maybe-list-node (token-forest-deepest-enclosing-list forest pos)) + (and maybe-list-node + ;; pos must be strictly inside the list body. + ;; Using LexerTokenSpan-end ensures we skip the entire delimiter, + ;; not just its first character. A position on the delimiter itself + ;; is a boundary, not inside the body, so it should not match. + (>= pos (LexerTokenSpan-end (Token-List-open-span maybe-list-node))) + (for/first ([child (in-list (Token-List-children maybe-list-node))] + #:when (and (non-skippable-node? child) + (Token-Leaf? child) + (token-leaf-type? child 'symbol))) + (Token-Leaf-span child)))) + +;; Return a list of (start . end) pairs for every sexp-comment (#;) +;; node in the forest. Walks recursively, so nested sexp-comments +;; under another sexp-comment are not double-counted. +(define (token-forest-sexp-comment-spans forest) + (define result '()) + (define (walk node) + (if (sexp-comment-node? node) + (set! result (cons (token-node-span node) result)) + (for-each walk (token-node-children node)))) + (for-each walk (Token-Forest-nodes forest)) + (reverse result)) + +(provide token-forest-flattened-nodes + token-forest-node-path + token-node-parent/path + token-forest-ancestors-at-pos + token-forest-deepest-enclosing-list + token-forest-form-head + token-forest-sexp-comment-spans) diff --git a/tests/lib/lexer-test.rkt b/tests/lib/lexer-test.rkt index 4a9e973..ceedded 100644 --- a/tests/lib/lexer-test.rkt +++ b/tests/lib/lexer-test.rkt @@ -23,6 +23,42 @@ (for/list ([entry (in-lexer-snapshot (build-lexer-snapshot text))]) entry)) + (define (match-range rx text) + (match (regexp-match-positions rx text) + [(list (cons start end)) (CharRange start end)])) + + (test-case + "find-token-index-at-or-before returns false before the first token" + (define tokens + (vector (make-lexer-span 2 4 'symbol) + (make-lexer-span 6 8 'symbol))) + (check-false (find-token-index-at-or-before tokens 1)) + (check-equal? (find-token-index-at-or-before tokens 2) 0) + (check-equal? (find-token-index-at-or-before tokens 5) 0) + (check-equal? (find-token-index-at-or-before tokens 9) 1)) + + (test-case + "find-token-index-at-or-after returns false after the last token" + (define tokens + (vector (make-lexer-span 2 4 'symbol) + (make-lexer-span 6 8 'symbol))) + (check-equal? (find-token-index-at-or-after tokens 1) 0) + (check-equal? (find-token-index-at-or-after tokens 2) 0) + (check-equal? (find-token-index-at-or-after tokens 5) 1) + (check-false (find-token-index-at-or-after tokens 8))) + + (test-case + "find-token-index-at returns false outside token spans" + (define tokens + (vector (make-lexer-span 2 4 'symbol) + (make-lexer-span 6 8 'symbol))) + (check-false (find-token-index-at tokens 1)) + (check-equal? (find-token-index-at tokens 2) 0) + (check-false (find-token-index-at tokens 4)) + (check-false (find-token-index-at tokens 5)) + (check-equal? (find-token-index-at tokens 7) 1) + (check-false (find-token-index-at tokens 8))) + (test-case "build-lexer-snapshot enumerates public lexer entries" (define snapshot (build-lexer-snapshot "#lang racket\n(define x 1)\n")) @@ -142,10 +178,11 @@ (Token-Leaf-span (first (Token-Prefix-Tree-skippable-nodes node)))) 'white-space) (check-true (Token-Leaf? (Token-Prefix-Tree-child node))) + (check-equal? (Token-Prefix-Tree-end node) 4) (check-equal? next-index 3))) (test-case - "token tree end uses the last child for unclosed lists" + "token tree end is cached for unclosed lists" (define-values (non-empty-node non-empty-next-index) (parse-token-node (vector (make-lexer-span 0 1 'open-paren) @@ -155,13 +192,15 @@ 0)) (check-equal? non-empty-next-index 4) (check-equal? (token-node-end non-empty-node) 13) + (check-equal? (Token-List-end non-empty-node) 13) (define-values (empty-node empty-next-index) (parse-token-node (vector (make-lexer-span 0 1 'open-paren)) 0)) (check-equal? empty-next-index 1) - (check-equal? (token-node-end empty-node) 1)) + (check-equal? (token-node-end empty-node) 1) + (check-equal? (Token-List-end empty-node) 1)) (test-case "token tree skips leading trivia and sexp comments" @@ -176,16 +215,169 @@ (check-equal? next-index 5) (check-equal? (length nodes) 3) (check-true (Token-Leaf? (first nodes))) - (check-equal? (LexerTokenSpan-type (Token-Leaf-span (first nodes))) - 'white-space) + (check-true (token-leaf-type? (first nodes) 'white-space)) (check-true (Token-Leaf? (second nodes))) - (check-equal? (LexerTokenSpan-type (Token-Leaf-span (second nodes))) - 'comment) + (check-true (token-leaf-type? (second nodes) 'comment)) (check-true (Token-Prefix-Tree? (third nodes))) (check-equal? (LexerTokenSpan-type (Token-Prefix-Tree-prefix-span (third nodes))) 'sexp-comment)) + (test-case + "snapshot token forest is built separately from flat snapshot" + (define snapshot (build-lexer-snapshot "(outer (inner x))")) + (define forest (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) + (define inner-list (token-forest-deepest-enclosing-list forest 9)) + (check-true (Token-List? inner-list)) + (check-equal? (LexerTokenSpan-start (Token-List-open-span inner-list)) 7) + (let-values ([(parent path) (token-node-parent/path forest inner-list)]) + (check-true (Token-List? parent)) + (check-equal? (LexerTokenSpan-start (Token-List-open-span parent)) 0) + (check-equal? (length path) 2))) + + (test-case + "token forest keeps sexp comment ranges" + (define text "#lang racket\n#; (define x 1)\n(+ 1 2)\n") + (define snapshot (build-lexer-snapshot text)) + (define forest (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) + (check-equal? + (token-forest-sexp-comment-spans forest) + (list (match-range #px"#; \\(define x 1\\)" text)))) + + (test-case + "token forest does not parse non-sexp body" + (define text "#lang scribble/manual\n@section{Hi}\n") + (define snapshot (build-lexer-snapshot text "file:///tmp/demo.scrbl")) + (define forest (build-snapshot-token-forest (LexerSnapshot-text snapshot) + "file:///tmp/demo.scrbl" + (LexerSnapshot-tokens snapshot))) + (define header-end (CharRange-end (match-range #px"#lang scribble/manual" text))) + (check-false + (for/or ([node (in-list (token-forest-flattened-nodes forest))]) + (> (token-node-end node) header-end))) + ;; The truncated forest contains no lists, so tree queries return #f. + (check-false (token-forest-deepest-enclosing-list forest 28))) + + (test-case + "parse-token-forest respects start-idx and excludes earlier tokens" + (define spans (vector (make-lexer-span 0 1 'open-paren) + (make-lexer-span 1 2 'symbol) + (make-lexer-span 2 3 'close-paren) + (make-lexer-span 3 4 'symbol))) + (define forest0 (parse-token-forest spans)) + (check-equal? (length (Token-Forest-nodes forest0)) 2) + (define forest1 (parse-token-forest spans 3)) + (check-equal? (length (Token-Forest-nodes forest1)) 1) + (define leaf (first (Token-Forest-nodes forest1))) + (check-true (Token-Leaf? leaf)) + (check-true (token-leaf-type? leaf 'symbol))) + + (test-case + "build-snapshot-token-forest for sexp docs starts after language header" + (define text "#lang racket\n(define x 1)\n") + (define snapshot (build-lexer-snapshot text)) + (define forest (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) + ;; The #lang token should not appear in the body forest. + (check-false + (for/or ([node (in-list (token-forest-flattened-nodes forest))]) + (<= (token-node-start node) 0 (token-node-end node)))) + ;; The body form (define x 1) should be present. + (check-not-false + (token-forest-deepest-enclosing-list forest 15))) + + (test-case + "build-snapshot-token-forest keeps first form without a language header" + (define text "(first x)\n(second y)\n") + (define snapshot (build-lexer-snapshot text)) + (define forest (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) + (check-equal? + (for/list ([node (in-list (Token-Forest-nodes forest))] + #:when (Token-List? node)) + (token-node-span node)) + (list (match-range #px"\\(first x\\)" text) + (match-range #px"\\(second y\\)" text)))) + + (test-case + "build-snapshot-token-forest keeps raw module body in sexp docs" + (define text "(module demo racket/base (define x 1))\n") + (define snapshot (build-lexer-snapshot text)) + (define forest (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) + (define body-range (match-range #px"\\(define x 1\\)" text)) + (check-not-false + (token-forest-deepest-enclosing-list forest + (CharRange-start body-range)))) + + (test-case + "lexer-state-body-forest caches result" + (define text "#lang racket\n(define x 1)\n") + (define state (build-lexer-state text #f)) + (define first (lexer-state-body-forest state text #f)) + (define second (lexer-state-body-forest state text #f)) + (check-eq? first second)) + + (test-case + "flat token queries work on non-sexp documents without a meaningful body forest" + (define text "#lang scribble/manual\n@section{Hi}\n") + (define snapshot (build-lexer-snapshot text "file:///tmp/demo.scrbl")) + ;; token-at and symbol-at are flat queries: they should work even when + ;; the document body is not sexp. + (check-equal? + (LexerEntry-text (lexer-snapshot-token-at snapshot 6)) + "#lang scribble/manual") + (check-equal? + (LexerEntry-type (lexer-snapshot-token-at snapshot 6)) + 'lang-directive) + (check-false (lexer-snapshot-symbol-at snapshot 6)) + ;; `section` is a symbol token in the body. + (check-equal? + (LexerEntry-text (lexer-snapshot-symbol-at snapshot 23)) + "section") + (check-equal? + (LexerEntry-type (lexer-snapshot-symbol-at snapshot 23)) + 'symbol)) + + (test-case + "unknown-language body mode is unknown" + (define text "#lang not-a-real-language\n(define x 1)\n") + (define snapshot (build-lexer-snapshot text)) + (define info (lexer-language-info (LexerSnapshot-text snapshot) + (LexerSnapshot-tokens snapshot))) + (check-equal? (Language-Info-body-mode info) 'unknown)) + + (test-case + "unknown-language still builds a forest for editor affordances" + (define text "#lang not-a-real-language\n(define x 1)\n") + (define state (build-lexer-state text #f)) + (check-not-false (lexer-state-body-forest state text #f)) + (check-equal? + (token-forest-sexp-comment-spans + (lexer-state-body-forest state text #f)) + '())) + + (test-case + "unknown #reader and raw modules also produce unknown language info" + (define reader-text "#reader does/not/exist\nbody\n") + (define reader-snapshot (build-lexer-snapshot reader-text)) + (define reader-info (lexer-language-info (LexerSnapshot-text reader-snapshot) + (LexerSnapshot-tokens reader-snapshot))) + (check-equal? (Language-Info-body-mode reader-info) 'unknown) + + (define module-text "(module demo does/not/exist (define x 1))\n") + (define module-snapshot (build-lexer-snapshot module-text)) + (define module-info (lexer-language-info (LexerSnapshot-text module-snapshot) + (LexerSnapshot-tokens module-snapshot))) + (check-equal? (Language-Info-body-mode module-info) 'unknown)) + (test-case "lexer snapshot position queries return token and symbol entries" (define snapshot @@ -224,21 +416,33 @@ (list 25 26 " " 'white-space))) (test-case - "lexer snapshot next symbol start skips whitespace tokens" + "tree query first meaningful symbol skips whitespace tokens" (define snapshot (build-lexer-snapshot "#lang racket/base\n( list)\n(+ 1 2)\n")) - (check-equal? (lexer-snapshot-next-symbol-start snapshot 20) 21) - (check-equal? (lexer-snapshot-next-symbol-start snapshot 21) 21) - (check-equal? (lexer-snapshot-next-symbol-start snapshot 27) #f)) + (define forest + (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) + (check-equal? + (LexerTokenSpan-start (token-forest-form-head forest 20)) + 21) + (check-equal? + (LexerTokenSpan-start (token-forest-form-head forest 21)) + 21) + (check-false (token-forest-form-head forest 27))) (test-case - "lexer snapshot next symbol start skips comments" + "tree query first meaningful symbol skips comments" (define text "#lang racket/base\n( ; comment\n list)\n") (define snapshot (build-lexer-snapshot text)) + (define forest + (build-snapshot-token-forest (LexerSnapshot-text snapshot) + #f + (LexerSnapshot-tokens snapshot))) (define d (make-doc "file:///comment-test.rkt" text)) (check-equal? - (lexer-snapshot-next-symbol-start snapshot - (doc-pos->abs-pos d (Pos 1 1))) + (LexerTokenSpan-start (token-forest-form-head forest + (doc-pos->abs-pos d (Pos 1 1)))) (doc-pos->abs-pos d (Pos 2 2)))) (test-case From fec109a7bbff5eb503ce2d60cf3cd4cc43d7c5fb Mon Sep 17 00:00:00 2001 From: 6cdh Date: Mon, 11 May 2026 12:03:07 +0800 Subject: [PATCH 11/17] Use token tree queries in document features --- doclib/doc.rkt | 140 +++++++++++++++++----------- lsp/text-document.rkt | 10 +- scribblings/racket-langserver.scrbl | 7 +- tests/lib/doc-test.rkt | 107 +++++++++++++++++++++ 4 files changed, 205 insertions(+), 59 deletions(-) diff --git a/doclib/doc.rkt b/doclib/doc.rkt index 94167ae..63234f3 100644 --- a/doclib/doc.rkt +++ b/doclib/doc.rkt @@ -20,6 +20,7 @@ racket/set racket/list racket/string + srfi/2 data/interval-map "check-syntax.rkt" "external/resyntax.rkt" @@ -35,7 +36,7 @@ [version exact-nonnegative-integer?] [trace-version (or/c false/c exact-nonnegative-integer?)] [resyntax-results (listof Resyntax-Result?)] - [lexer-snapshot (lazy-cache-of LexerSnapshot?)]) + [lexer-state (lazy-cache-of LexerState?)]) #:mutable) (define/contract (make-doc uri text [version 0]) @@ -51,8 +52,8 @@ (define (invalidate-resyntax-results! doc) (set-Doc-resyntax-results! doc (list))) -(define (invalidate-lexer-snapshot! doc) - (lazy-cache-invalidate! (Doc-lexer-snapshot doc))) +(define (invalidate-lexer-state! doc) + (lazy-cache-invalidate! (Doc-lexer-state doc))) (define/contract (doc-get-resyntax-results doc) (-> Doc? (listof Resyntax-Result?)) @@ -115,7 +116,7 @@ (define doc-trace (Doc-trace doc)) (invalidate-resyntax-results! doc) - (invalidate-lexer-snapshot! doc) + (invalidate-lexer-state! doc) (send doc-text erase) (send doc-trace reset) (send doc-text insert new-text 0)) @@ -163,7 +164,7 @@ (define/contract (doc-apply-edit! doc range text) (-> Doc? Range? string? void?) (invalidate-resyntax-results! doc) - (invalidate-lexer-snapshot! doc) + (invalidate-lexer-state! doc) (define start (doc-pos->abs-pos doc (Range-start range))) (define end (doc-pos->abs-pos doc (Range-end range))) (doc-apply-absolute-edit! doc start end text)) @@ -172,7 +173,7 @@ (-> Doc? (listof TextEdit?) void?) (unless (empty? edits) (invalidate-resyntax-results! doc) - (invalidate-lexer-snapshot! doc) + (invalidate-lexer-state! doc) ;; Apply from the end of the document so earlier edits do not shift ;; the positions of later edits. (define edits-descending-by-start @@ -270,20 +271,34 @@ (loop (interval-map-iterate-next intervals iter) (cons (interval-map-iterate-value intervals iter) values)))]))) +;; Return the absolute position of the opening delimiter of the innermost form +;; that contains `pos`, or #f when `pos` is outside any parsed form. (define/contract (doc-find-containing-paren doc pos) (-> Doc? exact-nonnegative-integer? (or/c exact-nonnegative-integer? #f)) - (lexer-snapshot-enclosing-paren-start (doc-lexer-snapshot doc) pos)) + (and-let* ([forest (doc-body-forest doc)] + [enclosing-list (token-forest-deepest-enclosing-list forest pos)]) + (LexerTokenSpan-start (Token-List-open-span enclosing-list)))) -;; Cache lexer-derived token ranges lazily. Query paths may build a cache miss -;; while the caller already holds whatever lock stabilizes the document state. -(define (doc-build-lexer-snapshot doc) - (build-lexer-snapshot (send (Doc-text doc) get-text))) +;; Cache lexer-derived state lazily. Query paths may build a cache miss while +;; the caller already holds whatever lock stabilizes the document state. +(define (doc-build-lexer-state doc) + (build-lexer-state (send (Doc-text doc) get-text) (Doc-uri doc))) -(define (doc-lexer-snapshot doc) +(define (doc-lexer-state doc) (call-with-lazy-cache! - (Doc-lexer-snapshot doc) + (Doc-lexer-state doc) (lambda () - (doc-build-lexer-snapshot doc)))) + (doc-build-lexer-state doc)))) + +(define (doc-lexer-snapshot doc) + (LexerState-snapshot (doc-lexer-state doc))) + +(define (doc-language-info doc) + (LexerState-language-info (doc-lexer-state doc))) + +(define (doc-body-forest doc) + (define state (doc-lexer-state doc)) + (lexer-state-body-forest state (send (Doc-text doc) get-text) (Doc-uri doc))) ;; definition BEG ;; @@ -354,12 +369,33 @@ ;; has line number 0 and character position 0. (define/contract (doc-range-tokens doc range) (-> Doc? Range? (listof SemanticToken?)) - (define tokens (send (Doc-trace doc) get-semantic-tokens)) (define pos-start (doc-pos->abs-pos doc (Range-start range))) (define pos-end (doc-pos->abs-pos doc (Range-end range))) - (filter-not (λ (tok) (or (<= (SemanticToken-end tok) pos-start) - (>= (SemanticToken-start tok) pos-end))) - tokens)) + (define tokens + (append (send (Doc-trace doc) get-semantic-tokens) + (doc-sexp-comment-semantic-tokens doc))) + (split-semantic-tokens-by-line + doc + (filter-not (λ (tok) (or (<= (SemanticToken-end tok) pos-start) + (>= (SemanticToken-start tok) pos-end))) + (sort tokens < #:key SemanticToken-start)))) + +(define (doc-sexp-comment-semantic-tokens doc) + (for/list ([span (in-list (token-forest-sexp-comment-spans (doc-body-forest doc)))]) + (SemanticToken (CharRange-start span) (CharRange-end span) SemanticTokenType-comment '()))) + +(define (split-semantic-tokens-by-line doc tokens) + (for*/list ([token (in-list tokens)] + [tstart (in-value (SemanticToken-start token))] + [tend (in-value (SemanticToken-end token))] + [type (in-value (SemanticToken-type token))] + [modifiers (in-value (SemanticToken-modifiers token))] + [start-line (in-value (Pos-line (doc-abs-pos->pos doc tstart)))] + [end-line (in-value (Pos-line (doc-abs-pos->pos doc (sub1 tend))))] + [line (in-range start-line (add1 end-line))] + [start (in-value (max tstart (doc-line-start-abs-pos doc line)))] + [end (in-value (min tend (doc-line-end-abs-pos doc line)))]) + (SemanticToken start end type modifiers))) (define/contract (doc-token-at doc pos) (-> Doc? exact-nonnegative-integer? (or/c LexerEntry? #f)) @@ -454,46 +490,40 @@ (append trace-actions resyntax-actions)) +(define (doc-signature-form-head-pos doc query-pos) + (define forest (doc-body-forest doc)) + (define maybe-head (token-forest-form-head forest query-pos)) + (and maybe-head (LexerTokenSpan-start maybe-head))) + +(define (doc-signature-tag doc-trace snapshot callee-pos) + (define maybe-docs-entry + (interval-map-ref (send doc-trace get-docs) callee-pos #f)) + (cond + [maybe-docs-entry (last maybe-docs-entry)] + [else + (define maybe-symbol (lexer-snapshot-symbol-at snapshot callee-pos)) + (and maybe-symbol + (id-to-tag (LexerEntry-text maybe-symbol) doc-trace))])) + +(define (tag->signature-help tag) + (match-define (list signatures docs) (get-docs-for-tag tag)) + (and signatures + (SignatureHelp + #:signatures + (for/list ([signature (in-list signatures)]) + (SignatureInformation + #:label signature + #:documentation (or docs "")))))) + (define/contract (doc-signature-help doc pos) (-> Doc? Pos? (or/c SignatureHelp? #f)) (define doc-trace (Doc-trace doc)) - (define pos* (doc-pos->abs-pos doc pos)) - (define pos-before-cursor (sub1 pos*)) - (define new-pos - (and (not (negative? pos-before-cursor)) - (doc-find-containing-paren doc pos-before-cursor))) - (define result - (cond [new-pos - (define maybe-callee-pos - (lexer-snapshot-next-symbol-start (doc-lexer-snapshot doc) (add1 new-pos))) - (define maybe-tag - (and maybe-callee-pos - (interval-map-ref (send doc-trace get-docs) maybe-callee-pos #f))) - (define tag - (cond [maybe-tag (last maybe-tag)] - [else - (define symbol - (and maybe-callee-pos - (lexer-snapshot-symbol-at (doc-lexer-snapshot doc) - maybe-callee-pos))) - (cond [symbol - (id-to-tag (LexerEntry-text symbol) doc-trace)] - [else #f])])) - (cond [tag - (match-define (list sigs docs) (get-docs-for-tag tag)) - (if sigs - (SignatureHelp - #:signatures - (map (lambda (sig) - (SignatureInformation - #:label sig - #:documentation (or docs ""))) - sigs)) - #f)] - [else #f])] - [else #f])) - result) + (define callee-pos (doc-signature-form-head-pos doc pos*)) + (define tag + (and callee-pos + (doc-signature-tag doc-trace (doc-lexer-snapshot doc) callee-pos))) + (and tag (tag->signature-help tag))) ;; Get the declaration at a given position in the document. ;; Returns (values start end decl) where decl is a Decl or #f. @@ -712,6 +742,8 @@ doc-range-tokens doc-token-at doc-token-prefix-at + doc-language-info + doc-body-forest doc-expand doc-update-trace! doc-trace-latest? diff --git a/lsp/text-document.rkt b/lsp/text-document.rkt index 6f5edfc..4c1ac87 100644 --- a/lsp/text-document.rkt +++ b/lsp/text-document.rkt @@ -262,8 +262,16 @@ (Range (doc-abs-pos->pos doc current-line-start-pos) (doc-abs-pos->pos doc current-line-end-pos))) + ;; TODO: Gate this sexp-structure lookup to sexp languages, or keep + ;; non-sexp documents on current-line formatting only. (define (containing-form-range) - (define maybe-paren-pos (doc-find-containing-paren doc (max 0 (sub1 ch-pos)))) + (define raw-pos (max 0 (sub1 ch-pos))) + (define token (doc-token-at doc raw-pos)) + (define query-pos + (if (and token (eq? 'close-paren (LexerEntry-type token))) + (add1 raw-pos) + raw-pos)) + (define maybe-paren-pos (doc-find-containing-paren doc query-pos)) (define start-pos (if (false? maybe-paren-pos) 0 maybe-paren-pos)) (Range (doc-abs-pos->pos doc start-pos) (doc-abs-pos->pos doc current-line-end-pos))) diff --git a/scribblings/racket-langserver.scrbl b/scribblings/racket-langserver.scrbl index cd1ac62..c27977e 100644 --- a/scribblings/racket-langserver.scrbl +++ b/scribblings/racket-langserver.scrbl @@ -447,10 +447,9 @@ indices into the document text) as well as LSP @racket[Pos] structs (line/charac @defproc[(doc-find-containing-paren [doc Doc?] [pos exact-nonnegative-integer?]) (or/c exact-nonnegative-integer? #f)]{ - Scans backward from @tt{pos} and returns the absolute offset of the nearest - unmatched opening parenthesis or bracket (@tt{(} or @tt{[}), or @racket[#f] if - none is found. - This is a character-level heuristic, not a full parse. + Returns the absolute offset of the opening delimiter of the innermost + parsed form (parenthesized or bracketed s-expression) that contains @tt{pos}, + or @racket[#f] if @tt{pos} is outside any parsed form. } @subsection{Trace and Expansion} diff --git a/tests/lib/doc-test.rkt b/tests/lib/doc-test.rkt index 679b980..f646c78 100644 --- a/tests/lib/doc-test.rkt +++ b/tests/lib/doc-test.rkt @@ -89,6 +89,8 @@ (check-equal? (doc-find-containing-paren d 2) 0) ;; at 1 (just after open paren) (check-equal? (doc-find-containing-paren d 1) 0) + ;; at last position (close-paren at buffer end, still inside the form) + (check-equal? (doc-find-containing-paren d 9) 0) (define text2 "((a) b)") (define d2 (make-doc "file:///test.rkt" text2)) @@ -170,6 +172,33 @@ (check-equal? (token-summary (doc-token-at d 0)) (list 0 3 "foo" 'symbol))) + (test-case + "doc-token-at works on a non-sexp document without depending on body forest" + (define text "#lang scribble/manual\n@section{Hi}\n") + (define d (make-doc "file:///test.scrbl" text)) + ;; Flat token queries should work even for non-sexp languages. + (check-equal? (LexerEntry-text (doc-token-at d 6)) "#lang scribble/manual") + (check-equal? (LexerEntry-type (doc-token-at d 6)) 'lang-directive) + (check-equal? (doc-token-prefix-at d 6) "#lang s")) + + (test-case + "doc-body-forest builds a forest for unknown languages" + (define text "#lang not-a-real-language\n(define x 1)\n") + (define d (make-doc "file:///test.unknown" text)) + (check-not-false (doc-body-forest d))) + + (test-case + "doc-find-containing-paren works for unknown languages" + (define text "#lang not-a-real-language\n(define x 1)\n") + (define d (make-doc "file:///test.unknown" text)) + (check-equal? (doc-find-containing-paren d 28) 26)) + + (test-case + "doc-find-containing-paren fallback keeps the first form without a language header" + (define d (make-doc "file:///test.rkt" "(first x)\n(second y)\n")) + (check-equal? (doc-find-containing-paren d 2) 0) + (check-equal? (doc-find-containing-paren d 12) 10)) + (test-case "Range tokens (Semantic Tokens)" (define text "#lang racket\n(define x 1)") @@ -184,6 +213,33 @@ (check-true (andmap SemanticToken? after-expand))) + (test-case + "Range tokens include sexp comment semantic tokens" + (define text "#lang racket\n#; (define x 1)\n(+ 1 2)") + (define d (make-doc "file:///test.rkt" text)) + (define comment-range (first (regexp-match-positions #px"#; \\(define x 1\\)" text))) + (define tokens (doc-range-tokens d (Range (Pos 0 0) (Pos 2 7)))) + (define comment-token + (findf (lambda (token) + (eq? (SemanticToken-type token) SemanticTokenType-comment)) + tokens)) + (check-true (SemanticToken? comment-token)) + (check-equal? (SemanticToken-start comment-token) (car comment-range)) + (check-equal? (SemanticToken-end comment-token) (cdr comment-range))) + + (test-case + "Range tokens split multi-line sexp comment semantic tokens" + (define text "#lang racket\n#;\n(define x 1)\n(+ 1 2)") + (define d (make-doc "file:///test.rkt" text)) + (define tokens (doc-range-tokens d (Range (Pos 0 0) (Pos 3 7)))) + (define comment-ranges + (for/list ([token (in-list tokens)] + #:when (eq? (SemanticToken-type token) SemanticTokenType-comment)) + (cons (SemanticToken-start token) (SemanticToken-end token)))) + (check-equal? comment-ranges + (list (first (regexp-match-positions #px"#;" text)) + (first (regexp-match-positions #px"\\(define x 1\\)" text))))) + (test-case "Formatting" ;; doc.rkt `doc-format-edits` delegates to the external formatter. @@ -754,6 +810,57 @@ END (check-true (string-contains? (SignatureInformation-label first-sig) "list") "label should contain 'list'")) + (test-case + "Document signature help outside a closed top-level form returns #f" + (define text +#< Date: Thu, 14 May 2026 10:40:46 +0800 Subject: [PATCH 12/17] Refactor lexer modules Extract snapshot.rkt and state.rkt from monolithic lexer.rkt, update callers and tests. --- doclib/doc-lang.rkt | 2 +- doclib/doc.rkt | 15 +-- doclib/lexer.rkt | 238 +++--------------------------------- doclib/lexer/scan.rkt | 2 +- doclib/lexer/shared.rkt | 32 ----- doclib/lexer/snapshot.rkt | 130 ++++++++++++++++++++ doclib/lexer/state.rkt | 119 ++++++++++++++++++ doclib/lexer/token-tree.rkt | 2 +- doclib/lexer/tree-query.rkt | 2 +- tests/lib/lexer-test.rkt | 19 ++- 10 files changed, 290 insertions(+), 271 deletions(-) delete mode 100644 doclib/lexer/shared.rkt create mode 100644 doclib/lexer/snapshot.rkt create mode 100644 doclib/lexer/state.rkt diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index 02bd16c..4c7699f 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -2,7 +2,7 @@ (require "../common/path-util.rkt" "lexer/scan.rkt" - "lexer/shared.rkt" + "lexer/snapshot.rkt" "lexer/token-tree.rkt" racket/contract racket/list diff --git a/doclib/doc.rkt b/doclib/doc.rkt index 63234f3..ca89a42 100644 --- a/doclib/doc.rkt +++ b/doclib/doc.rkt @@ -13,6 +13,8 @@ "formatting.rkt" "internal-types.rkt" "lexer.rkt" + (only-in "lexer/state.rkt" + lexer-state-body-forest) "doc-lang.rkt" racket/match racket/contract @@ -20,7 +22,6 @@ racket/set racket/list racket/string - srfi/2 data/interval-map "check-syntax.rkt" "external/resyntax.rkt" @@ -275,9 +276,7 @@ ;; that contains `pos`, or #f when `pos` is outside any parsed form. (define/contract (doc-find-containing-paren doc pos) (-> Doc? exact-nonnegative-integer? (or/c exact-nonnegative-integer? #f)) - (and-let* ([forest (doc-body-forest doc)] - [enclosing-list (token-forest-deepest-enclosing-list forest pos)]) - (LexerTokenSpan-start (Token-List-open-span enclosing-list)))) + (lexer-state-containing-open-paren (doc-lexer-state doc) pos)) ;; Cache lexer-derived state lazily. Query paths may build a cache miss while ;; the caller already holds whatever lock stabilizes the document state. @@ -297,8 +296,7 @@ (LexerState-language-info (doc-lexer-state doc))) (define (doc-body-forest doc) - (define state (doc-lexer-state doc)) - (lexer-state-body-forest state (send (Doc-text doc) get-text) (Doc-uri doc))) + (lexer-state-body-forest (doc-lexer-state doc))) ;; definition BEG ;; @@ -381,7 +379,7 @@ (sort tokens < #:key SemanticToken-start)))) (define (doc-sexp-comment-semantic-tokens doc) - (for/list ([span (in-list (token-forest-sexp-comment-spans (doc-body-forest doc)))]) + (for/list ([span (in-list (lexer-state-sexp-comment-spans (doc-lexer-state doc)))]) (SemanticToken (CharRange-start span) (CharRange-end span) SemanticTokenType-comment '()))) (define (split-semantic-tokens-by-line doc tokens) @@ -491,8 +489,7 @@ (append trace-actions resyntax-actions)) (define (doc-signature-form-head-pos doc query-pos) - (define forest (doc-body-forest doc)) - (define maybe-head (token-forest-form-head forest query-pos)) + (define maybe-head (lexer-state-form-head-at (doc-lexer-state doc) query-pos)) (and maybe-head (LexerTokenSpan-start maybe-head))) (define (doc-signature-tag doc-trace snapshot callee-pos) diff --git a/doclib/lexer.rkt b/doclib/lexer.rkt index 8a75ecd..81a331c 100644 --- a/doclib/lexer.rkt +++ b/doclib/lexer.rkt @@ -1,236 +1,34 @@ #lang racket/base -(require "../common/interfaces.rkt" - "doc-lang.rkt" - "lazy-cache.rkt" - "lexer/scan.rkt" - "lexer/shared.rkt" - "lexer/token-tree.rkt" - "lexer/tree-query.rkt" - racket/contract - racket/match) +(require "doc-lang.rkt" + "lexer/snapshot.rkt" + "lexer/state.rkt") -;; Upstream lexer type docs: -;; https://docs.racket-lang.org/syntax-color/Racket_Lexer.html -;; https://docs.racket-lang.org/syntax-color/Module_Lexer.html -;; -;; `racket-lexer` reports one of these type symbols: -;; - 'error: malformed input, such as an unterminated string or bad char literal. -;; - 'comment: ordinary comments, block comments, and special comments. -;; - 'sexp-comment: the `#;` token that comments out the following datum. -;; - 'white-space: spaces, tabs, and newlines. -;; - 'constant: datum-like literals and reader forms such as numbers, -;; booleans, and some quoting/prefix tokens. -;; - 'string: string literals. -;; - 'no-color: a non-whitespace token that should be left plain/uncolored. -;; The framework docs call this out explicitly, and `racket-lexer` uses it -;; for specials that do not map to a richer token class. -;; - 'parenthesis: grouping delimiters like `(`, `)`, `[`, `]`, `{`, and `}`. -;; - 'hash-colon-keyword: keywords like `#:name`. -;; - 'symbol: identifiers and operator names. -;; - 'eof: end of input. -;; - 'other: punctuation or reader/control tokens that do not fit the other -;; buckets, such as `,` and the `#lang` line when lexed directly. -;; -;; `module-lexer` returns the same kind of type information for `#lang`-aware -;; lexing. For installed `#lang` languages such as Rhombus, it can dispatch to -;; that language's `color-lexer`; when a colorer reports an attribute hash it -;; extracts the `'type` field. -;; -;; The scan layer normalizes token kinds so callers see stable shapes across -;; valid and invalid inputs: -;; - 'lang-directive: a leading `#lang` -;; - 'reader-directive: a leading `#reader` -;; - quote-family and syntax quote-family prefixes, plus `#;` -;; - open-paren/close-paren direction for the internal span cache -;; -;; This module is the public lexer facade. It builds snapshots from normalized -;; token spans, attaches a token forest, and exposes position-oriented queries. - -(define/contract (lexer-snapshot-span->entry snapshot span) - (-> LexerSnapshot? LexerTokenSpan? LexerEntry?) - (LexerEntry (LexerTokenSpan-start span) - (LexerTokenSpan-end span) - (substring (LexerSnapshot-text snapshot) - (LexerTokenSpan-start span) - (LexerTokenSpan-end span)) - (LexerTokenSpan-type span))) - -(define (lexer-token-span-contains-pos? span pos) - (and (<= (LexerTokenSpan-start span) pos) - (< pos (LexerTokenSpan-end span)))) - -;; Find the token at `pos`, or the next token after `pos` when `pos` falls -;; between token spans. Returns #f when `pos` is after the last token. -(define (find-token-index-at-or-after tokens pos) - (define token-count (vector-length tokens)) - (let loop ([low 0] - [high token-count]) - (cond - [(= low high) - (and (< low token-count) low)] - [else - (define mid (quotient (+ low high) 2)) - (define span (vector-ref tokens mid)) - (if (<= (LexerTokenSpan-end span) pos) - (loop (add1 mid) high) - (loop low mid))]))) - -(define (find-token-index-at tokens pos) - (define idx (find-token-index-at-or-after tokens pos)) - (and idx - (let ([span (vector-ref tokens idx)]) - (and (lexer-token-span-contains-pos? span pos) idx)))) - -(define (lookup-lexer-entry snapshot pos) - (define tokens (LexerSnapshot-tokens snapshot)) - (define idx (find-token-index-at tokens pos)) - (and idx - (lexer-snapshot-span->entry snapshot (vector-ref tokens idx)))) - -;; Find the token at `pos`, or the last token before `pos` when `pos` falls -;; between token spans. Returns #f when `pos` is before the first token. -(define (find-token-index-at-or-before tokens pos) - (define token-count (vector-length tokens)) - (define idx (find-token-index-at-or-after tokens pos)) - (cond - [(not idx) - (and (positive? token-count) (sub1 token-count))] - [else - (define span (vector-ref tokens idx)) - (cond - [(lexer-token-span-contains-pos? span pos) idx] - [(zero? idx) #f] - [else (sub1 idx)])])) - -;; Build a token forest from token spans. Uses language info to decide what -;; portion of the spans to parse: for non-sexp languages only the prefix is -;; parsed; for sexp languages, the body starting at body-start-idx is parsed. -(define (build-snapshot-token-forest text uri spans) - (define info (lexer-language-info text spans uri)) - (define total (vector-length spans)) - (define body-start-idx - (cond [(Language-Info-prefix info) - => Language-Prefix-body-start-idx] - [else 0])) - (define-values (start end) - (cond - [(eq? 'non-sexp (Language-Info-body-mode info)) - (values 0 body-start-idx)] - [else - (values (if (and (< body-start-idx total) - (span-at spans body-start-idx)) - body-start-idx - 0) - total)])) - (parse-token-forest spans start end)) - -(define/contract (in-lexer-snapshot snapshot) - (-> LexerSnapshot? sequence?) - (define tokens (LexerSnapshot-tokens snapshot)) - (define token-count (vector-length tokens)) - (let ([idx 0]) - (in-producer - (lambda () - (cond - [(= idx token-count) eof] - [else - (define entry - (lexer-snapshot-span->entry snapshot (vector-ref tokens idx))) - (set! idx (add1 idx)) - entry])) - eof))) - -(define/contract (for-each-lexer-snapshot-entry snapshot proc) - (-> LexerSnapshot? (-> LexerEntry? any/c) void?) - (for ([entry (in-lexer-snapshot snapshot)]) - (proc entry))) - -;; Flat token queries — these never need a token forest. - -(define/contract (lexer-snapshot-token-at snapshot pos) - (-> LexerSnapshot? exact-nonnegative-integer? (or/c LexerEntry? #f)) - (lookup-lexer-entry snapshot pos)) - -(define/contract (lexer-snapshot-symbol-at snapshot pos) - (-> LexerSnapshot? exact-nonnegative-integer? (or/c LexerEntry? #f)) - (define entry (lookup-lexer-entry snapshot pos)) - (and entry - (eq? (LexerEntry-type entry) 'symbol) - entry)) - -;; Structural tree queries — these require a token forest. -;; Callers should ensure the document is in a sexp-compatible body mode. - -(define/contract (build-lexer-snapshot text [uri #f]) - (->* (string?) ((or/c #f string?)) LexerSnapshot?) - (define token-span-vector (text->lexer-token-spans text)) - (LexerSnapshot text token-span-vector)) - -;; LexerState groups the flat snapshot, language metadata, and a lazy body-forest -;; cache. Documents keep one LexerState instead of separate caches for snapshot, -;; language, and forest. The forest covers whatever portion of the token spans is -;; relevant for the language's body mode (full file for sexp/unknown, header-only -;; for non-sexp). -(struct/contract LexerState - ([snapshot LexerSnapshot?] - [language-info Language-Info?] - [body-forest-cache (lazy-cache-of Token-Forest?)]) - #:transparent) - -(define (build-lexer-state text uri) - (define snapshot (build-lexer-snapshot text uri)) - (define info (lexer-language-info (LexerSnapshot-text snapshot) - (LexerSnapshot-tokens snapshot) - uri)) - (LexerState snapshot info (make-lazy-cache))) - -(define (lexer-state-body-forest state text uri) - (call-with-lazy-cache! - (LexerState-body-forest-cache state) - (lambda () - (build-snapshot-token-forest text - uri - (LexerSnapshot-tokens (LexerState-snapshot state)))))) +;; Public lexer facade. Lower modules expose parser and tree internals for +;; focused tests, but ordinary callers should use this stable API. (provide (struct-out LexerTokenSpan) (struct-out LexerSnapshot) - LexerSnapshot? - token-node? - sexp-comment-node? - token-node-children - token-node-span - parse-token-forest - token-forest-flattened-nodes - token-forest-node-path - token-node-parent/path - token-forest-ancestors-at-pos - token-forest-deepest-enclosing-list - token-forest-form-head - token-forest-sexp-comment-spans - (struct-out Token-Leaf) - (struct-out Token-List) - (struct-out Token-Prefix-Tree) - (struct-out Token-Forest) build-lexer-snapshot build-lexer-state - build-snapshot-token-forest LexerState? LexerState-snapshot LexerState-language-info - lexer-state-body-forest - lexer-language-info - Language-Info - Language-Info? - Language-Info-prefix - Language-Info-language - Language-Info-body-mode + lexer-state-body-mode + lexer-state-token-at + lexer-state-symbol-at + lexer-state-containing-open-paren + lexer-state-form-head-at + lexer-state-sexp-comment-spans lexer-snapshot-span->entry lexer-token-span-contains-pos? in-lexer-snapshot for-each-lexer-snapshot-entry - find-token-index-at - find-token-index-at-or-before - find-token-index-at-or-after lexer-snapshot-token-at - lexer-snapshot-symbol-at) + lexer-snapshot-symbol-at + lexer-language-info + Language-Info + Language-Info? + Language-Info-prefix + Language-Info-language + Language-Info-body-mode) diff --git a/doclib/lexer/scan.rkt b/doclib/lexer/scan.rkt index ca7db77..91c2c90 100644 --- a/doclib/lexer/scan.rkt +++ b/doclib/lexer/scan.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "shared.rkt" +(require "snapshot.rkt" racket/contract racket/match racket/string diff --git a/doclib/lexer/shared.rkt b/doclib/lexer/shared.rkt deleted file mode 100644 index 359de52..0000000 --- a/doclib/lexer/shared.rkt +++ /dev/null @@ -1,32 +0,0 @@ -#lang racket/base - -(require racket/contract) - -;; Shared lexer data shapes. Keep this module independent from scanning and -;; token-tree parsing so the rest of the lexer stack can depend on common data -;; without forming cycles. - -(struct/contract LexerTokenSpan - ([start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [type symbol?]) - #:transparent) - -(struct/contract LexerSnapshot - ([text string?] - [tokens (vectorof LexerTokenSpan?)]) - #:transparent) - -(define (make-lexer-span start end type) - (and (< start end) - (LexerTokenSpan start end type))) - -(define (span-at spans idx) - (and (<= 0 idx) - (< idx (vector-length spans)) - (vector-ref spans idx))) - -(provide (struct-out LexerTokenSpan) - (struct-out LexerSnapshot) - make-lexer-span - span-at) diff --git a/doclib/lexer/snapshot.rkt b/doclib/lexer/snapshot.rkt new file mode 100644 index 0000000..e54d89a --- /dev/null +++ b/doclib/lexer/snapshot.rkt @@ -0,0 +1,130 @@ +#lang racket/base + +(require "../../common/interfaces.rkt" + racket/contract) + +;; Flat lexer data shapes and position-oriented snapshot queries. Keep this +;; module independent from scanning and token-tree parsing so the rest of the +;; lexer stack can depend on common data without forming cycles. + +(struct/contract LexerTokenSpan + ([start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [type symbol?]) + #:transparent) + +(struct/contract LexerSnapshot + ([text string?] + [tokens (vectorof LexerTokenSpan?)]) + #:transparent) + +(define (make-lexer-span start end type) + (and (< start end) + (LexerTokenSpan start end type))) + +(define (span-at spans idx) + (and (<= 0 idx) + (< idx (vector-length spans)) + (vector-ref spans idx))) + +(define/contract (lexer-snapshot-span->entry snapshot span) + (-> LexerSnapshot? LexerTokenSpan? LexerEntry?) + (LexerEntry (LexerTokenSpan-start span) + (LexerTokenSpan-end span) + (substring (LexerSnapshot-text snapshot) + (LexerTokenSpan-start span) + (LexerTokenSpan-end span)) + (LexerTokenSpan-type span))) + +(define (lexer-token-span-contains-pos? span pos) + (and (<= (LexerTokenSpan-start span) pos) + (< pos (LexerTokenSpan-end span)))) + +;; Find the token at `pos`, or the next token after `pos` when `pos` falls +;; between token spans. Returns #f when `pos` is after the last token. +(define (find-token-index-at-or-after tokens pos) + (define token-count (vector-length tokens)) + (let loop ([low 0] + [high token-count]) + (cond + [(= low high) + (and (< low token-count) low)] + [else + (define mid (quotient (+ low high) 2)) + (define span (vector-ref tokens mid)) + (if (<= (LexerTokenSpan-end span) pos) + (loop (add1 mid) high) + (loop low mid))]))) + +(define (find-token-index-at tokens pos) + (define idx (find-token-index-at-or-after tokens pos)) + (and idx + (let ([span (vector-ref tokens idx)]) + (and (lexer-token-span-contains-pos? span pos) idx)))) + +(define (lookup-lexer-entry snapshot pos) + (define tokens (LexerSnapshot-tokens snapshot)) + (define idx (find-token-index-at tokens pos)) + (and idx + (lexer-snapshot-span->entry snapshot (vector-ref tokens idx)))) + +;; Find the token at `pos`, or the last token before `pos` when `pos` falls +;; between token spans. Returns #f when `pos` is before the first token. +(define (find-token-index-at-or-before tokens pos) + (define token-count (vector-length tokens)) + (define idx (find-token-index-at-or-after tokens pos)) + (cond + [(not idx) + (and (positive? token-count) (sub1 token-count))] + [else + (define span (vector-ref tokens idx)) + (cond + [(lexer-token-span-contains-pos? span pos) idx] + [(zero? idx) #f] + [else (sub1 idx)])])) + +(define/contract (in-lexer-snapshot snapshot) + (-> LexerSnapshot? sequence?) + (define tokens (LexerSnapshot-tokens snapshot)) + (define token-count (vector-length tokens)) + (let ([idx 0]) + (in-producer + (lambda () + (cond + [(= idx token-count) eof] + [else + (define entry + (lexer-snapshot-span->entry snapshot (vector-ref tokens idx))) + (set! idx (add1 idx)) + entry])) + eof))) + +(define/contract (for-each-lexer-snapshot-entry snapshot proc) + (-> LexerSnapshot? (-> LexerEntry? any/c) void?) + (for ([entry (in-lexer-snapshot snapshot)]) + (proc entry))) + +(define/contract (lexer-snapshot-token-at snapshot pos) + (-> LexerSnapshot? exact-nonnegative-integer? (or/c LexerEntry? #f)) + (lookup-lexer-entry snapshot pos)) + +(define/contract (lexer-snapshot-symbol-at snapshot pos) + (-> LexerSnapshot? exact-nonnegative-integer? (or/c LexerEntry? #f)) + (define entry (lookup-lexer-entry snapshot pos)) + (and entry + (eq? (LexerEntry-type entry) 'symbol) + entry)) + +(provide (struct-out LexerTokenSpan) + (struct-out LexerSnapshot) + make-lexer-span + span-at + lexer-snapshot-span->entry + lexer-token-span-contains-pos? + find-token-index-at + find-token-index-at-or-before + find-token-index-at-or-after + in-lexer-snapshot + for-each-lexer-snapshot-entry + lexer-snapshot-token-at + lexer-snapshot-symbol-at) diff --git a/doclib/lexer/state.rkt b/doclib/lexer/state.rkt new file mode 100644 index 0000000..54aca58 --- /dev/null +++ b/doclib/lexer/state.rkt @@ -0,0 +1,119 @@ +#lang racket/base + +(require "../../common/interfaces.rkt" + "../doc-lang.rkt" + "../lazy-cache.rkt" + "scan.rkt" + "snapshot.rkt" + "token-tree.rkt" + "tree-query.rkt" + racket/contract) + +;; `LexerState` groups the flat snapshot, language metadata, and a lazy +;; body-forest cache. Documents keep one LexerState instead of separate caches +;; for snapshot, language, and forest. +(struct/contract LexerState + ([snapshot LexerSnapshot?] + [language-info Language-Info?] + [body-forest-cache (lazy-cache-of Token-Forest?)]) + #:transparent) + +(define/contract (build-lexer-snapshot text [uri #f]) + (->* (string?) ((or/c #f string?)) LexerSnapshot?) + (define token-span-vector (text->lexer-token-spans text)) + (LexerSnapshot text token-span-vector)) + +(define (lexer-state-body-mode state) + (Language-Info-body-mode (LexerState-language-info state))) + +(define (language-info-body-start-idx info) + (cond [(Language-Info-prefix info) + => Language-Prefix-body-start-idx] + [else 0])) + +(define (forest-range-for-language-info info spans) + (define total (vector-length spans)) + (define body-start-idx (language-info-body-start-idx info)) + (cond + [(eq? 'non-sexp (Language-Info-body-mode info)) + (values 0 body-start-idx)] + [else + (values (if (and (< body-start-idx total) + (span-at spans body-start-idx)) + body-start-idx + 0) + total)])) + +(define (build-token-forest-for-language-info info spans) + (define-values (start end) + (forest-range-for-language-info info spans)) + (parse-token-forest spans start end)) + +;; Build a token forest from token spans. Uses language info to decide what +;; portion of the spans to parse: for non-sexp languages only the prefix is +;; parsed; for sexp languages, the body starting at body-start-idx is parsed. +(define (build-snapshot-token-forest text uri spans) + (define info (lexer-language-info text spans uri)) + (build-token-forest-for-language-info info spans)) + +(define (build-lexer-state text uri) + (define snapshot (build-lexer-snapshot text uri)) + (define info (lexer-language-info (LexerSnapshot-text snapshot) + (LexerSnapshot-tokens snapshot) + uri)) + (LexerState snapshot info (make-lazy-cache))) + +(define (lexer-state-body-forest state) + (call-with-lazy-cache! + (LexerState-body-forest-cache state) + (lambda () + (build-token-forest-for-language-info + (LexerState-language-info state) + (LexerSnapshot-tokens (LexerState-snapshot state)))))) + +(define/contract (lexer-state-token-at state pos) + (-> LexerState? exact-nonnegative-integer? (or/c LexerEntry? #f)) + (lexer-snapshot-token-at (LexerState-snapshot state) pos)) + +(define/contract (lexer-state-symbol-at state pos) + (-> LexerState? exact-nonnegative-integer? (or/c LexerEntry? #f)) + (lexer-snapshot-symbol-at (LexerState-snapshot state) pos)) + +(define (lexer-state-structural-forest state) + (and (not (eq? 'non-sexp (lexer-state-body-mode state))) + (lexer-state-body-forest state))) + +(define/contract (lexer-state-containing-open-paren state pos) + (-> LexerState? exact-nonnegative-integer? (or/c exact-nonnegative-integer? #f)) + (define maybe-forest (lexer-state-structural-forest state)) + (and maybe-forest + (let ([enclosing-list + (token-forest-deepest-enclosing-list maybe-forest pos)]) + (and enclosing-list + (LexerTokenSpan-start + (Token-List-open-span enclosing-list)))))) + +(define/contract (lexer-state-form-head-at state pos) + (-> LexerState? exact-nonnegative-integer? (or/c LexerTokenSpan? #f)) + (define maybe-forest (lexer-state-structural-forest state)) + (and maybe-forest + (token-forest-form-head maybe-forest pos))) + +(define/contract (lexer-state-sexp-comment-spans state) + (-> LexerState? (listof CharRange?)) + (define maybe-forest (lexer-state-structural-forest state)) + (if maybe-forest + (token-forest-sexp-comment-spans maybe-forest) + '())) + +(provide (struct-out LexerState) + build-lexer-snapshot + build-lexer-state + build-snapshot-token-forest + lexer-state-body-mode + lexer-state-body-forest + lexer-state-token-at + lexer-state-symbol-at + lexer-state-containing-open-paren + lexer-state-form-head-at + lexer-state-sexp-comment-spans) diff --git a/doclib/lexer/token-tree.rkt b/doclib/lexer/token-tree.rkt index e4f8c85..72dbc79 100644 --- a/doclib/lexer/token-tree.rkt +++ b/doclib/lexer/token-tree.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "shared.rkt" +(require "snapshot.rkt" "../../common/interfaces.rkt" racket/list racket/match) diff --git a/doclib/lexer/tree-query.rkt b/doclib/lexer/tree-query.rkt index 9effa51..3f99f85 100644 --- a/doclib/lexer/tree-query.rkt +++ b/doclib/lexer/tree-query.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "shared.rkt" +(require "snapshot.rkt" "token-tree.rkt") ;; Structural queries over a Token-Forest. This module depends on the node diff --git a/tests/lib/lexer-test.rkt b/tests/lib/lexer-test.rkt index ceedded..79c50ba 100644 --- a/tests/lib/lexer-test.rkt +++ b/tests/lib/lexer-test.rkt @@ -4,9 +4,16 @@ (require rackunit "../../doclib/doc.rkt" "../../doclib/lexer.rkt" - (only-in "../../doclib/lexer/shared.rkt" - make-lexer-span) + (only-in "../../doclib/lexer/snapshot.rkt" + make-lexer-span + find-token-index-at + find-token-index-at-or-before + find-token-index-at-or-after) + (only-in "../../doclib/lexer/state.rkt" + build-snapshot-token-forest + lexer-state-body-forest) "../../doclib/lexer/token-tree.rkt" + "../../doclib/lexer/tree-query.rkt" "../../common/interfaces.rkt") (define (entry-summary entry) @@ -321,8 +328,8 @@ "lexer-state-body-forest caches result" (define text "#lang racket\n(define x 1)\n") (define state (build-lexer-state text #f)) - (define first (lexer-state-body-forest state text #f)) - (define second (lexer-state-body-forest state text #f)) + (define first (lexer-state-body-forest state)) + (define second (lexer-state-body-forest state)) (check-eq? first second)) (test-case @@ -358,10 +365,10 @@ "unknown-language still builds a forest for editor affordances" (define text "#lang not-a-real-language\n(define x 1)\n") (define state (build-lexer-state text #f)) - (check-not-false (lexer-state-body-forest state text #f)) + (check-not-false (lexer-state-body-forest state)) (check-equal? (token-forest-sexp-comment-spans - (lexer-state-body-forest state text #f)) + (lexer-state-body-forest state)) '())) (test-case From e027030db147afa204abb87864bdc75574111b06 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Thu, 14 May 2026 22:49:37 +0800 Subject: [PATCH 13/17] Merge sexp comment tokens and other tokens correctly --- doclib/doc.rkt | 47 ++++++++++++++++++++++++++++++++++------ tests/lib/doc-test.rkt | 49 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 90 insertions(+), 6 deletions(-) diff --git a/doclib/doc.rkt b/doclib/doc.rkt index ca89a42..493c986 100644 --- a/doclib/doc.rkt +++ b/doclib/doc.rkt @@ -369,19 +369,54 @@ (-> Doc? Range? (listof SemanticToken?)) (define pos-start (doc-pos->abs-pos doc (Range-start range))) (define pos-end (doc-pos->abs-pos doc (Range-end range))) - (define tokens - (append (send (Doc-trace doc) get-semantic-tokens) - (doc-sexp-comment-semantic-tokens doc))) (split-semantic-tokens-by-line doc - (filter-not (λ (tok) (or (<= (SemanticToken-end tok) pos-start) - (>= (SemanticToken-start tok) pos-end))) - (sort tokens < #:key SemanticToken-start)))) + (filter (λ (token) + (char-range-intersect? + (SemanticToken-start token) + (SemanticToken-end token) + pos-start pos-end)) + (doc-semantic-tokens doc)))) (define (doc-sexp-comment-semantic-tokens doc) (for/list ([span (in-list (lexer-state-sexp-comment-spans (doc-lexer-state doc)))]) (SemanticToken (CharRange-start span) (CharRange-end span) SemanticTokenType-comment '()))) +(define (doc-semantic-tokens doc) + (define trace-tokens + (sort (send (Doc-trace doc) get-semantic-tokens) < #:key SemanticToken-start)) + (define sexp-comment-tokens + (sort (doc-sexp-comment-semantic-tokens doc) < #:key SemanticToken-start)) + (merge-semantic-tokens trace-tokens sexp-comment-tokens)) + +(define (merge-semantic-tokens tokens high-priority-tokens [merged '()]) + (define (continue-merge tokens merged) + (cond [(empty? tokens) + (reverse merged)] + [else + (continue-merge (rest tokens) (cons (car tokens) merged))])) + + (define (merge-non-empty-stream tokens high-priority-tokens merged) + (define ht (car high-priority-tokens)) + (define t (car tokens)) + (define ht-start (SemanticToken-start ht)) + (define ht-end (SemanticToken-end ht)) + (define t-start (SemanticToken-start t)) + (define t-end (SemanticToken-end t)) + (cond [(<= t-end ht-start) + (merge-semantic-tokens (cdr tokens) high-priority-tokens (cons t merged))] + [(<= ht-end t-start) + (merge-semantic-tokens tokens (cdr high-priority-tokens) (cons ht merged))] + [else + (merge-semantic-tokens (cdr tokens) high-priority-tokens merged)])) + + (cond [(empty? high-priority-tokens) + (continue-merge tokens merged)] + [(empty? tokens) + (continue-merge high-priority-tokens merged)] + [else + (merge-non-empty-stream tokens high-priority-tokens merged)])) + (define (split-semantic-tokens-by-line doc tokens) (for*/list ([token (in-list tokens)] [tstart (in-value (SemanticToken-start token))] diff --git a/tests/lib/doc-test.rkt b/tests/lib/doc-test.rkt index f646c78..c7c40f9 100644 --- a/tests/lib/doc-test.rkt +++ b/tests/lib/doc-test.rkt @@ -240,6 +240,55 @@ (list (first (regexp-match-positions #px"#;" text)) (first (regexp-match-positions #px"\\(define x 1\\)" text))))) + (test-case + "Range tokens remove stale trace tokens inside current sexp comments" + (define text "#lang racket\n(define x 1)\nx\n") + (define d (make-doc "file:///test.rkt" text)) + (check-true (doc-expand! d)) + + (doc-apply-edit! d (Range (Pos 1 0) (Pos 1 0)) "#; ") + + (define updated-text (doc-get-text d)) + (define comment-range + (first (regexp-match-positions #px"#; \\(define x 1\\)" updated-text))) + (define tokens (doc-range-tokens d (Range (Pos 0 0) (Pos 3 0)))) + (define-values (comment-start comment-end) + (values (car comment-range) (cdr comment-range))) + (define (token-intersects-comment? token) + (char-range-intersect? (SemanticToken-start token) + (SemanticToken-end token) + comment-start + comment-end)) + (define (comment-token? token) + (eq? (SemanticToken-type token) SemanticTokenType-comment)) + (define (token-starts-before? left right) + (<= (SemanticToken-start left) (SemanticToken-start right))) + + (define comment-token + (findf (λ (token) + (and (comment-token? token) + (= (SemanticToken-start token) comment-start) + (= (SemanticToken-end token) comment-end))) + tokens)) + (define non-comment-tokens + (filter-not comment-token? tokens)) + + (check-true (SemanticToken? comment-token)) + (check-false + (ormap token-intersects-comment? non-comment-tokens) + "current sexp-comment span should mask intersecting stale trace tokens") + (check-not-false + (findf (λ (token) + (and (not (comment-token? token)) + (not (token-intersects-comment? token)))) + tokens) + "stale trace tokens outside the comment should be preserved") + (check-true + (for/and ([left (in-list tokens)] + [right (in-list (rest tokens))]) + (token-starts-before? left right)) + "semantic tokens should remain monotonic for LSP relative encoding")) + (test-case "Formatting" ;; doc.rkt `doc-format-edits` delegates to the external formatter. From 3a937ca60dc63221f199356bee9e2490ab7049da Mon Sep 17 00:00:00 2001 From: 6cdh Date: Fri, 15 May 2026 22:01:50 +0800 Subject: [PATCH 14/17] Fix semantic tokens requests bug Fix semantic-token requests that miss current lexer-derived `#;` comment tokens after expansion has already failed. Add Check-Syntax-Status struct and gate semantic-token wait on running status: - Rename new-trace to check-syntax-finished scheduler signal. Add with-read-safedoc / with-write-safedoc eliminators. --- .lispwords | 2 + lsp/safedoc.rkt | 82 +++++++++++++++++++++----- lsp/scheduler.rkt | 18 +++--- lsp/text-document.rkt | 35 ++++++----- tests/lib/scheduler-test.rkt | 16 +++++ tests/textDocument/semantic-tokens.rkt | 62 +++++++++++++++++++ 6 files changed, 175 insertions(+), 40 deletions(-) create mode 100644 tests/textDocument/semantic-tokens.rkt diff --git a/.lispwords b/.lispwords index edfbf12..78f7802 100644 --- a/.lispwords +++ b/.lispwords @@ -1,6 +1,8 @@ (match-define 1) (with-read-doc 1) (with-write-doc 1) +(with-read-safedoc 1) +(with-write-safedoc 1) (syntax-parse 1) (define-json-expander 1) (for/fold/derived 2) diff --git a/lsp/safedoc.rkt b/lsp/safedoc.rkt index 14ba45f..eb3d259 100644 --- a/lsp/safedoc.rkt +++ b/lsp/safedoc.rkt @@ -14,14 +14,25 @@ racket/set "../common/json-util.rkt" "../common/settings.rkt" - racket/class) + racket/class + racket/contract) + +;; Tracks a check-syntax run for a specific document version. +;; state: 'running, 'succeeded, or 'failed +;; version: document version the run was started on +(struct/contract Check-Syntax-Status + ([state (or/c 'running 'succeeded 'failed)] + [version exact-nonnegative-integer?]) + #:transparent) -;; SafeDoc has two eliminators: -;; with-read-doc: access Doc within a reader lock. -;; with-write-doc: access Doc within a writer lock. -;; Access its fields without protection should not be allowed. +;; SafeDoc eliminators: +;; with-read-safedoc / with-write-safedoc — get safe-doc, access any field +;; with-read-doc / with-write-doc — get doc only (legacy) +;; Exported field accessors: SafeDoc-doc, SafeDoc-check-syntax-status. +;; Access fields only inside an eliminator that acquired the lock. (struct SafeDoc - (doc rwlock token) + (doc rwlock token check-syntax-status) + #:mutable #:transparent) (define (new-safedoc uri text version) @@ -29,7 +40,7 @@ ;; Token identifies this opened document instance in scheduler/query state. (define token (gensym 'doc-token)) (scheduler-register-doc! token) - (SafeDoc doc (make-rwlock) token)) + (SafeDoc doc (make-rwlock) token #f)) (define (with-read-doc safe-doc proc) (call-with-read-lock @@ -41,6 +52,23 @@ (SafeDoc-rwlock safe-doc) (λ () (proc (SafeDoc-doc safe-doc))))) +(define (with-read-safedoc safe-doc proc) + (call-with-read-lock + (SafeDoc-rwlock safe-doc) + (λ () (proc safe-doc)))) + +(define (with-write-safedoc safe-doc proc) + (call-with-write-lock + (SafeDoc-rwlock safe-doc) + (λ () (proc safe-doc)))) + +(define (safedoc-check-syntax-running? sd) + (define doc (SafeDoc-doc sd)) + (define status (SafeDoc-check-syntax-status sd)) + (and (Check-Syntax-Status? status) + (eq? 'running (Check-Syntax-Status-state status)) + (equal? (Check-Syntax-Status-version status) (Doc-version doc)))) + ;; TODO: add uri to each Diagnostic struct when make them, and remove uri here ;; Currently it uses the `uri` of the document that triggers ;; the check-syntax. But some diagnostics may come from other files. @@ -58,12 +86,21 @@ ;; The only place that actually runs check-syntax. (define (safedoc-run-check-syntax! notify-client safe-doc) (define-values (uri working-version text-buffer-copy token) - (with-read-doc safe-doc - (lambda (doc) + (with-read-safedoc safe-doc + (lambda (sd) + (define doc (SafeDoc-doc sd)) (values (Doc-uri doc) (Doc-version doc) (doc-copy-text-buffer doc) - (SafeDoc-token safe-doc))))) + (SafeDoc-token sd))))) + + (with-write-safedoc safe-doc + (lambda (sd) + (define doc (SafeDoc-doc sd)) + (when (equal? working-version (Doc-version doc)) + (set-SafeDoc-check-syntax-status! + sd + (Check-Syntax-Status 'running working-version))))) (define (resyntax-task) (define text (send text-buffer-copy get-text)) @@ -77,8 +114,9 @@ (define (check-syntax-task) (define result (doc-expand uri text-buffer-copy)) - (with-write-doc safe-doc - (lambda (doc) + (with-write-safedoc safe-doc + (lambda (sd) + (define doc (SafeDoc-doc sd)) (define cur-version (Doc-version doc)) (define trace (CSResult-trace result)) (define diags (set->list (send trace get-warn-diags))) @@ -88,16 +126,30 @@ (equal? working-version cur-version)) (doc-update-trace! doc trace cur-version) (when (and (get-resyntax-enabled) (resyntax-available?)) - (scheduler-push-task! token 'resyntax resyntax-task))))) - (clear-old-queries/new-trace token)) + (scheduler-push-task! token 'resyntax resyntax-task))) + (when (equal? working-version (Doc-version doc)) + (set-SafeDoc-check-syntax-status! + sd + (Check-Syntax-Status + (if (CSResult-succeed? result) + 'succeeded + 'failed) + working-version))))) + (clear-old-queries/check-syntax-finished token)) (scheduler-stop-all-tasks! token) (scheduler-push-task! token 'check-syntax check-syntax-task)) (provide SafeDoc-token SafeDoc? + SafeDoc-doc + SafeDoc-check-syntax-status + (struct-out Check-Syntax-Status) new-safedoc safedoc-run-check-syntax! + safedoc-check-syntax-running? with-read-doc - with-write-doc) + with-write-doc + with-read-safedoc + with-write-safedoc) diff --git a/lsp/scheduler.rkt b/lsp/scheduler.rkt index 2848bbf..ed2f868 100644 --- a/lsp/scheduler.rkt +++ b/lsp/scheduler.rkt @@ -110,14 +110,14 @@ ()) (define *doc-change-signal* (QuerySignal)) -(define *new-trace-signal* (QuerySignal)) +(define *check-syntax-finished-signal* (QuerySignal)) (define *doc-close-signal* (QuerySignal)) (define (signal-doc-change? s) (eq? s *doc-change-signal*)) -(define (signal-new-trace? s) - (eq? s *new-trace-signal*)) +(define (signal-check-syntax-finished? s) + (eq? s *check-syntax-finished-signal*)) (define (signal-doc-close? s) (eq? s *doc-close-signal*)) @@ -148,13 +148,13 @@ (λ () (run-and-remove-queries token *doc-change-signal*)))) -;; send new trace signal (when check syntax completed) and waiting for all waiting queries -;; to be processed. -(define (clear-old-queries/new-trace token) +;; Send check-syntax completion signal and wait for all waiting queries to be +;; processed. +(define (clear-old-queries/check-syntax-finished token) (call-with-semaphore *await-queries-semaphore* (λ () - (run-and-remove-queries token *new-trace-signal*)))) + (run-and-remove-queries token *check-syntax-finished-signal*)))) ;; send doc close signal so waiting query threads can finish and release any ;; document state they captured. @@ -166,9 +166,9 @@ (provide async-query-wait signal-doc-change? - signal-new-trace? + signal-check-syntax-finished? signal-doc-close? clear-old-queries/doc-change - clear-old-queries/new-trace + clear-old-queries/check-syntax-finished clear-old-queries/doc-close) diff --git a/lsp/text-document.rkt b/lsp/text-document.rkt index 4c1ac87..c62318a 100644 --- a/lsp/text-document.rkt +++ b/lsp/text-document.rkt @@ -331,25 +331,28 @@ (λ (pos) (doc-abs-pos->pos doc pos)) (doc-range-tokens doc range))) + (define (current-tokens sd) + (define doc (SafeDoc-doc sd)) + (if (or (doc-trace-latest? doc) + (not (safedoc-check-syntax-running? sd))) + (get-tokens-encoding doc) + #f)) + + (define (respond-to-signal signal) + (cond + [(signal-doc-close? signal) + (success/enc id (hash 'data '()))] + [else + (define tokens + (with-read-doc safe-doc get-tokens-encoding)) + (success/enc id (hash 'data tokens))])) + (define tokens - (with-read-doc safe-doc - (λ (doc) - (if (doc-trace-latest? doc) - (get-tokens-encoding doc) - #f)))) + (with-read-safedoc safe-doc current-tokens)) + (if tokens (success/enc id (hash 'data tokens)) - (async-query-wait - (SafeDoc-token safe-doc) - (λ (signal) - (cond - [(signal-doc-close? signal) - (success/enc id (hash 'data '()))] - [else - (define tokens - (with-read-doc safe-doc - get-tokens-encoding)) - (success/enc id (hash 'data tokens))]))))) + (async-query-wait (SafeDoc-token safe-doc) respond-to-signal))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/tests/lib/scheduler-test.rkt b/tests/lib/scheduler-test.rkt index 2bd9c27..42b42df 100644 --- a/tests/lib/scheduler-test.rkt +++ b/tests/lib/scheduler-test.rkt @@ -4,6 +4,22 @@ (require rackunit "../../lsp/scheduler.rkt") + (test-case + "clear-old-queries/check-syntax-finished releases waiting queries" + (define token (gensym 'doc-token)) + (define waiter + (async-query-wait token (lambda (signal) signal))) + (define result-box (box #f)) + (define waiter-thread + (thread + (lambda () + (set-box! result-box (waiter))))) + + (clear-old-queries/check-syntax-finished token) + + (check-not-false (sync/timeout 1.0 waiter-thread)) + (check-true (signal-check-syntax-finished? (unbox result-box)))) + (test-case "clear-old-queries/doc-close releases waiting queries" (define token (gensym 'doc-token)) diff --git a/tests/textDocument/semantic-tokens.rkt b/tests/textDocument/semantic-tokens.rkt new file mode 100644 index 0000000..b16febe --- /dev/null +++ b/tests/textDocument/semantic-tokens.rkt @@ -0,0 +1,62 @@ +#lang racket + +(define uri "file:///semantic-tokens-test.rkt") + +(define failing-code +#< Date: Sat, 6 Jun 2026 22:05:19 +0800 Subject: [PATCH 15/17] docs: add language support matrix and detailed feature documentation --- README.md | 69 ++++++++++++++++++-------- features.md | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 185 insertions(+), 20 deletions(-) create mode 100644 features.md diff --git a/README.md b/README.md index 1165657..25597bf 100644 --- a/README.md +++ b/README.md @@ -28,26 +28,55 @@ racket -l racket-langserver You may need to restart your LSP runtime or your editor for `racket-langserver` to start. -## Capabilities - -#### *Currently Supported:* - -- **Hover** (textDocument/hover) -- **Jump to Definition** (textDocument/definition) -- **Find References** (textDocument/references) - - *Note:* Currently only considers references from opened files within the workspace. -- **Document Highlight** (textDocument/documentHighlight) -- **Diagnostics** (textDocument/publishDiagnostics) -- **Code Formatting** (textDocument/formatting & textDocument/rangeFormatting & textDocument/onTypeFormatting) -- **Code Action** (textDocument/codeAction) -- **Signature Help** (textDocument/signatureHelp) -- **Rename** (textDocument/rename & textDocument/prepareRename) - - *Note:* Currently only allows renaming symbols defined within the current file. -- **Code completion** (textDocument/completion) - -#### *Work in Progress:* - -- **Document Outline** (textDocument/documentSymbol) +## Language Support + +The server recognizes language families and provides different levels of +support depending on whether the language uses s-expression syntax. + +- Racket - The standard Racket language (`#lang racket`, `#lang racket/*`, etc.). +- Typed Racket - (`#lang typed/racket`, `#lang typed/racket/*`, etc.). +- Other sexp - Predefined s-expression language families beyond Racket and Typed Racket. +- Scribble - (`#lang scribble`, `#lang scribble/*`, etc.). +- Rhombus - (`#lang rhombus`, `#lang rhombus/*`, etc.). +- Unknown - Language declaration found and parsed, but not in the predefined list. +- Unrecognized - No language declaration found (missing `#lang`, `#reader`, or `(module ...)` form). + +### Legend + +| Mark | Meaning | +|---|---| +| ✅ | Feature works well and produces useful results. | +| ⚠️ | Partial support - the feature runs but may produce incomplete or imprecise results. | +| ❌ | Not implemented or intentionally filtered out for this language family. | + +The matrix rates expected usefulness for each language family. Expansion-based features are marked supported when they only depend on successful expansion and `check-syntax` data. Features are marked partial when they have additional syntax-family limits, lexer limits, or intentionally noisy results. + +### Support Matrix + +| Feature | Racket | Typed Racket | Other sexp | Scribble | Rhombus | Unknown | Unrecognized | +|:---:|:---:|:---:|:---:|:---:|:---:|:---:|:---:| +| Completion | ✅ | ✅ | ✅ | ⚠️ | ⚠️ | ⚠️ | ⚠️ | +| Definition | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Hover | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Signature Help | ✅ | ✅ | ✅ | ❌ | ❌ | ⚠️ | ❌ | +| References | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Document Highlight | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Rename | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Prepare Rename | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Code Action | ✅ | ✅ | ✅ | ✅ | ✅ | ✅ | ❌ | +| Diagnostics | ✅ | ✅ | ✅ | ✅ | ✅ | ⚠️ | ✅ | +| Document Symbols | ⚠️ | ⚠️ | ⚠️ | ⚠️ | ⚠️ | ⚠️ | ⚠️ | +| Semantic Tokens, Delta | ❌ | ❌ | ❌ | ❌ | ❌ | ❌ | ❌ | +| Semantic Tokens, Full | ✅ | ✅ | ✅ | ⚠️ | ⚠️ | ⚠️ | ⚠️ | +| Semantic Tokens, Range | ✅ | ✅ | ✅ | ⚠️ | ⚠️ | ⚠️ | ⚠️ | +| Formatting | ✅ | ✅ | ✅ | ❌ | ❌ | ❌ | ❌ | +| Range Formatting | ✅ | ✅ | ✅ | ❌ | ❌ | ❌ | ❌ | +| On-Type Formatting | ✅ | ✅ | ✅ | ❌ | ❌ | ❌ | ❌ | +| Inlay Hints | ❌ | ❌ | ❌ | ❌ | ❌ | ❌ | ❌ | + +### Features + +See [features.md](features.md) for a detailed breakdown of each feature. ## Development diff --git a/features.md b/features.md new file mode 100644 index 0000000..6a3097f --- /dev/null +++ b/features.md @@ -0,0 +1,136 @@ +# Features + +For a quick overview of which features are supported per language family, see the **Support Matrix** in [README.md](README.md). + +Many features need your code to expand without errors. After each edit, the server tries re-expanding your file. Each new edit cancels any running expansion and starts a fresh one. Results from the last successful expansion stay available until the new one finishes, so features keep working during editing. If expansion never succeeds, features that require expansion will never return useful results. The code needs to be correct for at least one moment, and stay that correct state for a few seconds to let expansion finish. + +Expansion based features mostly use DrRacket's `check-syntax` APIs. The server expands the module, collects the binding, documentation, diagnostic, and highlighting information that `check-syntax` reports, and translates those results into LSP responses. + +Several features also use the lexer from `syntax-color`. The lexer dispatches to a language-specific tokenizer based on the `#lang` declaration. Recognized languages get accurate tokenization. Unrecognized languages fallback to the Racket lexer, which probably does not understand their syntax and produces unreliable tokens. + +## Integrations + +### Resyntax + +[Resyntax](https://github.com/jackfirth/resyntax) provides automated refactoring suggestions. If you have Resyntax installed, it is used automatically with no configuration. Suggestions appear as diagnostics and code actions in your editor. If Resyntax is not installed, the server works normally without it. + +### racket-fixw + +The Formatting feature uses [racket-fixw](https://github.com/6cdh/racket-fixw) for recognized sexp language indentation. This is a required dependency and is included when you install the server. Other external formatters can be supported, open an issue if you'd like one added. + +## Code Action *(requires expansion)* + +The Quick Fix menu offers two kinds of actions: + +- **Unused variable** suggests adding a `_` prefix to silence the warning. +- **Refactoring** suggestions powered by Resyntax, shown when Resyntax is installed. Resyntax works automatically with no configuration needed. If it is not installed, these suggestions are simply not shown. + +Uses DrRacket's `check-syntax` for unused variable detection. + +Language behavior: not filtered by language family. Works for any language where expansion succeeds and check-syntax or Resyntax produce useful results. + +## Completion *(identifier completion requires expansion)* + +The autocomplete popup provides two kinds of results: + +- **Identifiers** defined in your file and imported from required modules. These need expansion. +- **Module paths** for `require` forms, based on your installed collections. These work without expansion. It covers both bare paths like `racket/base` and string paths like `"racket/base"`. + +Identifier completion is powered by DrRacket's `check-syntax`. The server registers `(` as a trigger character. In VS Code, extensions control the `wordPattern` setting, it determines whether completion can trigger for other places except after `(`. + +Language behavior: not filtered by language family for either source. Identifier completion works where expansion succeeds and useful binding data is produced. Module-path completion works without expansion. The `(` trigger character is sexp-oriented. + +## Definition *(requires expansion)* + +Jump to the definition of the identifier under the cursor. Works for both local definitions and identifiers imported from other files. Powered by DrRacket's `check-syntax`. + +Language behavior: not filtered by language family. Works where expansion succeeds and check-syntax produces binding data with reliable source ranges. + +## Diagnostics *(expansion for 3 of 4 sources)* + +Problems are shown from these sources: + +- **Reader and expander errors** (syntax errors, missing modules, broken `.zo` files). Shown even if expansion fails. `.zo` version mismatch errors include a suggestion telling you which `raco` command to run. +- **Check-syntax warnings** for unused variables and unused `require` forms. These only appear after a successful expansion. Powered by DrRacket's `check-syntax`. +- **Typed Racket type errors** produced during expansion by the type checker. The server reads these from the type checker's log output. +- **Language declaration check** warns about missing `#lang` lines or unrecognized language names. Works without expansion. + +Language behavior: mostly not filtered by language family. Reader errors, expander errors, and check-syntax warnings work for any language that reads and expands. The language declaration check only recognizes the predefined language families, so other valid `#lang` names are reported as unrecognized. Typed Racket type errors are specific to Typed Racket. + +## Document Highlight *(requires expansion)* + +Placing the cursor on an identifier highlights all of its occurrences in the file. Both the definition site and all usage sites light up. The server uses `check-syntax` to find which declaration the identifier at the cursor resolves to, then looks up every location in the file that refers to the same declaration. + +Language behavior: not filtered by language family. Works where expansion succeeds and check-syntax produces binding data with reliable source ranges. + +## Document Symbols *(no expansion)* + +Shows a document outline. The server uses the lexer to produce results. It scans the text for every symbol (identifier), string, and constant and lists each one as a symbol entry with a kind label. This means every occurrence is listed rather than just top-level definitions, making the outline noisy and currently not very useful for navigation. + +Language behavior: not filtered by language family. The server does not actively suppress entries for any language family, but actual entries depend on what the lexer can tokenize. + +## Formatting *(no expansion)* + +Indents Racket code by calling an external formatter. Currently uses [racket-fixw](https://github.com/6cdh/racket-fixw). Works for recognized sexp language families. Does not change anything for other languages. + +Three trigger modes are supported: + +- Format document - indents the whole file. +- Format selection - indents only the selected lines. +- Format on type - indents when you press `)`, `]`, or Enter. Pressing `)` or `]` re-indents the enclosing form; pressing Enter re-indents the current line. + +Language behavior: only recognized sexp language families are supported. Other languages return no edits. + +## Hover *(requires expansion)* + +Hovering over an identifier shows: + +1. **Type or contract** - from check-syntax's mouse-over annotation, the same info DrRacket shows. +2. **Online docs link** - from check-syntax's doc annotation, turned into a `docs.racket-lang.org` URL. +3. **Locally installed documentation** — looked up via the check-syntax doc tag. Scribble blueboxes are preferred for formatted signatures. If they aren't available, the locally installed HTML docs are parsed instead. + +Language behavior: not filtered by language family. Works where expansion succeeds and check-syntax produces hover and documentation data with reliable source ranges. + +## Inlay Hints + +A handler is registered, but it is just a stub, not yet implemented. + +## References *(requires expansion)* + +Finds all references to the identifier under the cursor. Local references are always found via the `syncheck:add-jump-to-definition` and `syncheck:add-arrow/name-dup` check-syntax callbacks. Cross-file references only shows for identifiers that were referenced by a file in the workspace that has been opened and expanded, unopened files are not scanned. + +Language behavior: not filtered by language family. Works where expansion succeeds and check-syntax produces binding data with reliable source ranges. Cross-file references are limited to files that have been opened and expanded in the workspace. + +## Rename *(requires expansion)* + +Renames an identifier and all its uses within the current file. Collects the declaration position and all binding positions from check-syntax, then replaces each with the new name. Only identifiers defined in the current file can be renamed. + +Language behavior: not filtered by language family. Works where expansion succeeds and check-syntax produces binding data with reliable source ranges. + +## Prepare Rename *(requires expansion)* + +Called by the editor before the rename dialog opens to check whether renaming is allowed at the cursor position. + +Language behavior: same as Rename. + +## Semantic Tokens *(expansion for 2 of 3 sources)* + +Provides semantic syntax highlighting with token types like function, variable, string, number, and comment. Combines analysis from these sources: + +- DrRacket-style highlighting from check-syntax (needs expansion). +- Traverse the syntax tree (needs expansion). +- Sexp comment detection via the lexer, works without expansion. + +Supports highlighting the full document or a specified range. Delta (incremental) highlighting is not yet implemented. + +Semantic tokens depend on expansion and lexer data. Each request waits for any pending expansion to finish before responding. If expansion succeeds, fresh expansion-based tokens are used. If expansion fails, the last successful expansion tokens may remain available with adjusted ranges, and current lexer-derived sexp-comment tokens can still appear. If no expansion has ever succeeded, only lexer-derived tokens can appear. + +In Lisp, due to dynamic typing and the S-expression syntax, many identifiers share the same token type and look similar, so it is recommended to use a semantic token aware editor plugin that gives each different identifier a unique color. + +Language behavior: check-syntax color tokens are not filtered by language family and work where expansion succeeds. Sexp-comment tokens are available when the structural lexer can parse s-expression code. + +## Signature Help *(requires expansion)* + +Shows signature information when you are inside a form. The server finds the head symbol of the enclosing s-expression form and looks up its signatures using locally installed documentation. If expansion is in progress or has failed, the last successful result is used as a fallback. Powered by DrRacket's `check-syntax`. + +Language behavior: sexp-specific. Callee detection relies on s-expression form-head lookup through the structural forest. Known non-sexp languages return no result. From d068cf93ebeeb5037feae79fd2e2a93ea58c59b2 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sat, 6 Jun 2026 22:29:51 +0800 Subject: [PATCH 16/17] Add more Sexp languages to known language list --- doclib/doc-lang.rkt | 64 +++++++++++++++++++++++++++++++++++++ tests/lib/doc-lang-test.rkt | 51 +++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index 4c7699f..89a3c20 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -58,6 +58,70 @@ #:sexp? #t #:suffixes '() #:name-rx #px"^typed/racket(?:/.*)?$") + (Known-Language~kw #:name 'scheme + #:sexp? #t + #:suffixes '() + #:name-rx #px"^scheme(?:/.*)?$") + (Known-Language~kw #:name 'mzscheme + #:sexp? #t + #:suffixes '() + #:name-rx #px"^mzscheme$") + (Known-Language~kw #:name 'r5rs + #:sexp? #t + #:suffixes '() + #:name-rx #px"^r5rs$") + (Known-Language~kw #:name 'r6rs + #:sexp? #t + #:suffixes '() + #:name-rx #px"^r6rs$") + (Known-Language~kw #:name 'r7rs + #:sexp? #t + #:suffixes '() + #:name-rx #px"^r7rs$") + (Known-Language~kw #:name 'lazy + #:sexp? #t + #:suffixes '() + #:name-rx #px"^lazy$") + (Known-Language~kw #:name 'slideshow + #:sexp? #t + #:suffixes '() + #:name-rx #px"^slideshow$") + (Known-Language~kw #:name 'plai + #:sexp? #t + #:suffixes '() + #:name-rx #px"^plai(?:-typed|-lazy)?$") + (Known-Language~kw #:name 'plait + #:sexp? #t + #:suffixes '() + #:name-rx #px"^plait$") + (Known-Language~kw #:name 'htdp + #:sexp? #t + #:suffixes '() + #:name-rx #px"^htdp/(?:bsl\\+?|isl\\+?|asl)$") + (Known-Language~kw #:name 'eopl + #:sexp? #t + #:suffixes '() + #:name-rx #px"^eopl$") + (Known-Language~kw #:name 'sicp + #:sexp? #t + #:suffixes '() + #:name-rx #px"^sicp$") + (Known-Language~kw #:name 'swindle + #:sexp? #t + #:suffixes '() + #:name-rx #px"^swindle$") + (Known-Language~kw #:name 'frtime + #:sexp? #t + #:suffixes '() + #:name-rx #px"^frtime$") + (Known-Language~kw #:name 'rosette + #:sexp? #t + #:suffixes '() + #:name-rx #px"^rosette(?:/safe)?$") + (Known-Language~kw #:name 'pie + #:sexp? #t + #:suffixes '() + #:name-rx #px"^pie$") (Known-Language~kw #:name 'scribble #:sexp? #f #:suffixes '("scrbl") diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt index b86e60e..4aeedaa 100644 --- a/tests/lib/doc-lang-test.rkt +++ b/tests/lib/doc-lang-test.rkt @@ -153,10 +153,37 @@ 'racket) (check-equal? (language-name "#lang typed/racket/base\n(define x : Integer 1)\n") 'typed/racket) + (for ([lang+name (in-list '(("scheme" scheme) + ("scheme/base" scheme) + ("scheme/list" scheme) + ("mzscheme" mzscheme) + ("r5rs" r5rs) + ("r6rs" r6rs) + ("r7rs" r7rs) + ("lazy" lazy) + ("slideshow" slideshow) + ("plai" plai) + ("plai-typed" plai) + ("plai-lazy" plai) + ("plait" plait) + ("htdp/bsl" htdp) + ("htdp/isl" htdp) + ("htdp/isl+" htdp) + ("htdp/asl" htdp) + ("eopl" eopl) + ("sicp" sicp) + ("swindle" swindle) + ("frtime" frtime) + ("rosette" rosette) + ("rosette/safe" rosette) + ("pie" pie)))]) + (check-equal? (language-name (format "#lang ~a\n1\n" (first lang+name))) + (second lang+name))) (check-equal? (language-name "#reader scribble/reader\n@title{demo}\n") 'scribble) (check-equal? (language-name "#lang rhombus\nfun f(): 1\n") 'rhombus) + (check-false (parse-known-language "#lang s-exp racket/base\n1\n")) (check-equal? (parse-known-language "#lang not-a-real-language\n1\n") 'unrecognized-language) (check-equal? (parse-known-language "#reader does/not/exist\n") @@ -170,6 +197,20 @@ 'racket) (check-equal? (Known-Language-name (find-language-by-text "typed/racket/base")) 'typed/racket) + (check-equal? (Known-Language-name (find-language-by-text "scheme/base")) + 'scheme) + (check-equal? (Known-Language-name (find-language-by-text "r6rs")) + 'r6rs) + (check-equal? (Known-Language-name (find-language-by-text "htdp/isl+")) + 'htdp) + (check-equal? (Known-Language-name (find-language-by-text "rosette/safe")) + 'rosette) + (check-equal? (Known-Language-name (find-language-by-text "pie")) + 'pie) + (check-false (find-language-by-text "plai/foo")) + (check-false (find-language-by-text "htdp/bsl/foo")) + (check-false (find-language-by-text "rosette/unsafe")) + (check-false (find-language-by-text "s-exp racket/base")) (check-false (find-language-by-text "not-a-real-language"))) (test-case @@ -195,6 +236,16 @@ "sexp-language? is true only for known sexp families" (check-true (sexp-language? "#lang racket/base\n(define x 1)\n")) (check-true (sexp-language? "(module demo typed/racket/base (define x 1))\n")) + (check-true (sexp-language? "#lang scheme/base\n(define x 1)\n")) + (check-true (sexp-language? "#lang r5rs\n(define x 1)\n")) + (check-true (sexp-language? "#lang r6rs\n(import (rnrs))\n(define x 1)\n")) + (check-true (sexp-language? "#lang r7rs\n(define x 1)\n")) + (check-true (sexp-language? "#lang lazy\n(define x 1)\n")) + (check-true (sexp-language? "#lang htdp/isl+\n(define x 1)\n")) + (check-true (sexp-language? "#lang rosette\n(define x 1)\n")) + (check-true (sexp-language? "#lang pie\n(claim n Nat)\n")) + (check-false (sexp-language? "#lang plai/foo\n(define x 1)\n")) + (check-false (sexp-language? "#lang s-exp racket/base\n(define x 1)\n")) (check-false (sexp-language? "#lang scribble/manual\n@title{demo}\n")) (check-false (sexp-language? "fun f(): 1\n" "file:///tmp/demo.rhm")) (check-false (sexp-language? "(define x 1)\n" "file:///tmp/demo.rkt")))) From 1e7492260bdb4b9ae5bf5719bfffac0f791e9fd6 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sat, 6 Jun 2026 22:43:34 +0800 Subject: [PATCH 17/17] Centralize .rktd document policy Handle `.rktd` file policy logic in doc-lang module --- doclib/check-syntax.rkt | 12 ++++++------ doclib/doc-lang.rkt | 15 +++++++++++++++ doclib/service/diagnostic.rkt | 3 +-- tests/lib/doc-lang-test.rkt | 14 ++++++++++++++ 4 files changed, 36 insertions(+), 8 deletions(-) diff --git a/doclib/check-syntax.rkt b/doclib/check-syntax.rkt index eee67b6..6e21b44 100644 --- a/doclib/check-syntax.rkt +++ b/doclib/check-syntax.rkt @@ -8,6 +8,7 @@ racket/port "editor.rkt" "doc-trace.rkt" + "doc-lang.rkt" "../common/path-util.rkt" "internal-types.rkt") @@ -55,19 +56,18 @@ (define (check-syntax uri doc-text) (define path (uri->path uri)) (define text (send doc-text get-text)) - ; rktd <-> rkt is just like JSON <-> js - (define data-file? (equal? (path-get-extension path) #".rktd")) + (define expand? (requires-expansion? path)) (define new-trace (new build-trace% [src path] [doc-text doc-text])) (define in (open-input-string text)) - (define er (expand-source path in new-trace #:expand? (not data-file?))) + (define er (expand-source path in new-trace #:expand? expand?)) (send new-trace walk-stx er) (send new-trace walk-log (ExpandResult-logs er)) (CSResult new-trace text - (if data-file? - (and (ExpandResult-pre-syntax er) #t) - (ExpandResult-all-succeed? er)))) + (if expand? + (ExpandResult-all-succeed? er) + (and (ExpandResult-pre-syntax er) #t)))) (provide (struct-out CSResult) diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt index 89a3c20..e04b2bf 100644 --- a/doclib/doc-lang.rkt +++ b/doclib/doc-lang.rkt @@ -263,6 +263,18 @@ (and (regexp-match? (Known-Language-name-rx language) text) language))) +(define/contract (racket-data-file-path? path) + (-> path-string? boolean?) + (equal? (path-get-extension path) #".rktd")) + +(define/contract (requires-expansion? path) + (-> path-string? boolean?) + (not (racket-data-file-path? path))) + +(define/contract (requires-language-declaration? path) + (-> path-string? boolean?) + (not (racket-data-file-path? path))) + (define (uri->suffix uri) (define extension (path-get-extension (uri->path uri))) (bytes->string/utf-8 (subbytes extension 1))) @@ -366,6 +378,9 @@ Known-Language~kw known-languages find-language-by-text + racket-data-file-path? + requires-expansion? + requires-language-declaration? parse-language-prefix parse-language guess-language-by-uri diff --git a/doclib/service/diagnostic.rkt b/doclib/service/diagnostic.rkt index 576054d..381fc34 100644 --- a/doclib/service/diagnostic.rkt +++ b/doclib/service/diagnostic.rkt @@ -4,7 +4,6 @@ racket/class racket/string racket/set - racket/path racket/match racket/list setup/path-to-relative @@ -44,7 +43,7 @@ (define pre-exn (ExpandResult-pre-exn expand-result)) (define post-exn (ExpandResult-post-exn expand-result)) (define maybe-language-diag - (and (not (equal? (path-get-extension src) #".rktd")) + (and (requires-language-declaration? src) (language-diagnostic doc-text))) (when maybe-language-diag (add-diag! maybe-language-diag)) diff --git a/tests/lib/doc-lang-test.rkt b/tests/lib/doc-lang-test.rkt index 4aeedaa..e554ec1 100644 --- a/tests/lib/doc-lang-test.rkt +++ b/tests/lib/doc-lang-test.rkt @@ -232,6 +232,20 @@ 'scribble) (check-false (guess-language-by-uri "file:///tmp/demo.rkt"))) + (test-case + "rktd files are Racket data, not expandable modules" + (define path (string->path "/tmp/demo.rktd")) + (check-true (racket-data-file-path? path)) + (check-false (requires-expansion? path)) + (check-false (requires-language-declaration? path))) + + (test-case + "rkt files still require module policy" + (define path (string->path "/tmp/demo.rkt")) + (check-false (racket-data-file-path? path)) + (check-true (requires-expansion? path)) + (check-true (requires-language-declaration? path))) + (test-case "sexp-language? is true only for known sexp families" (check-true (sexp-language? "#lang racket/base\n(define x 1)\n"))