diff --git a/.lispwords b/.lispwords index 5a00c43..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) @@ -15,3 +17,4 @@ (call-with-write-lock 1) (define-syntax-parse-rule 1) (with-limits 2) +(and-let* 1) diff --git a/README.md b/README.md index cf496f9..21ffbd5 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/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/common/path-util.rkt b/common/path-util.rkt index bb571a1..ee61c70 100644 --- a/common/path-util.rkt +++ b/common/path-util.rkt @@ -5,15 +5,12 @@ 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:"))])) +(define uri->path (compose path->string url->path string->url)) (define (directory-contains? dir filepath) (define dir-parts (explode-path (simple-form-path dir))) diff --git a/doclib/check-syntax.rkt b/doclib/check-syntax.rkt index 7bf9e87..6e21b44 100644 --- a/doclib/check-syntax.rkt +++ b/doclib/check-syntax.rkt @@ -8,26 +8,10 @@ racket/port "editor.rkt" "doc-trace.rkt" + "doc-lang.rkt" "../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 #:expand? [expand? #t]) (define-values (src-dir _1 _2) (split-path path)) @@ -72,20 +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 indenter (if data-file? #f (get-indenter text))) - (define new-trace (new build-trace% [src path] [doc-text doc-text] [indenter indenter])) + (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) @@ -94,4 +76,3 @@ (#:expand? boolean?) ExpandResult?)] [check-syntax (-> string? (is-a?/c lsp-editor%) CSResult?)])) - diff --git a/doclib/doc-lang.rkt b/doclib/doc-lang.rkt new file mode 100644 index 0000000..e04b2bf --- /dev/null +++ b/doclib/doc-lang.rkt @@ -0,0 +1,389 @@ +#lang racket/base + +(require "../common/path-util.rkt" + "lexer/scan.rkt" + "lexer/snapshot.rkt" + "lexer/token-tree.rkt" + racket/contract + racket/list + racket/match + racket/path + racket/string) + +(define language-prefix-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-Prefix + ([source language-prefix-source/c] + [text string?] + [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [body-start-idx 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 '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") + #:name-rx #px"^scribble(?:/.*)?$") + (Known-Language~kw #:name 'rhombus + #:sexp? #f + #:suffixes '("rhm") + #:name-rx #px"^rhombus(?:/.*)?$"))) + +(define (source->text+spans source) + (cond + [(LexerSnapshot? source) + (values (LexerSnapshot-text source) (LexerSnapshot-tokens source))] + [(string? source) + (values source (text->lexer-token-spans source))])) + +(define (span-text text span) + (substring text + (LexerTokenSpan-start span) + (LexerTokenSpan-end span))) + +(define (token-node-text text node) + (substring text + (token-node-start node) + (token-node-end node))) + +(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 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 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 + ;; `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-prefix 'reader-lang reader-payload span header-end))] + [else #f])) + +(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-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 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 + ;; `#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 text span) span next-idx)] + [(Token-Leaf span) + #:when (eq? 'error (LexerTokenSpan-type 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? token-text) + (make-language-prefix 'malformed-lang-directive "" span next-idx)))] + [_ #f])) + +(define (leaf-symbol-text text node) + (match node + [(Token-Leaf span) + #:when (eq? 'symbol (LexerTokenSpan-type span)) + (span-text text span)] + [_ #f])) + +(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) + (read-next-non-skippable-nodes/spans spans next-idx 1)) + (match reader-nodes + [(list reader-node) + (Language-Prefix 'reader-directive + (token-node-text text reader-node) + (LexerTokenSpan-start span) + (token-node-end reader-node) + reader-idx)] + ['() + (make-language-prefix 'malformed-reader-directive "" span reader-idx)])] + [_ #f])) + +(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. + (cond + [(Token-List? node) + (define children (token-node-children node)) + (define (node-symbol-text 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-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-Prefix 'malformed-raw-module + "" + (token-node-start node) + (token-node-end node) + start-idx)] + [_ #f])] + [else #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/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))) + +(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 (parse-language-prefix-from-spans text spans [idx 0]) + (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 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-prefix source [idx 0]) + (->* ((or/c string? LexerSnapshot?)) + (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-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?)) + boolean?) + (define maybe-language (parse-language source uri)) + (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)) + (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-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 + racket-data-file-path? + requires-expansion? + requires-language-declaration? + parse-language-prefix + parse-language + guess-language-by-uri + lexer-language-info + 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..493c986 100644 --- a/doclib/doc.rkt +++ b/doclib/doc.rkt @@ -13,6 +13,9 @@ "formatting.rkt" "internal-types.rkt" "lexer.rkt" + (only-in "lexer/state.rkt" + lexer-state-body-forest) + "doc-lang.rkt" racket/match racket/contract racket/class @@ -34,7 +37,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]) @@ -44,14 +47,14 @@ (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) (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?)) @@ -114,7 +117,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)) @@ -162,7 +165,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)) @@ -171,7 +174,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 @@ -269,20 +272,31 @@ (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)) + (lexer-state-containing-open-paren (doc-lexer-state doc) pos)) -;; 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) + (lexer-state-body-forest (doc-lexer-state doc))) ;; definition BEG ;; @@ -337,11 +351,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. @@ -349,12 +367,68 @@ ;; 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)) + (split-semantic-tokens-by-line + doc + (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))] + [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)) @@ -449,46 +523,39 @@ (append trace-actions resyntax-actions)) +(define (doc-signature-form-head-pos doc 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) + (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. @@ -707,6 +774,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/doclib/lexer.rkt b/doclib/lexer.rkt index 6207c56..81a331c 100644 --- a/doclib/lexer.rkt +++ b/doclib/lexer.rkt @@ -1,264 +1,34 @@ #lang racket/base -(require "../common/interfaces.rkt" - racket/contract - racket/match - syntax-color/module-lexer - syntax-color/racket-lexer) +(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. -;; -;; 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. +;; Public lexer facade. Lower modules expose parser and tree internals for +;; focused tests, but ordinary callers should use this stable API. -;; 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?)]) - #: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-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))) - -(define (lexer-span->public snapshot span) - (LexerEntry (LexerTokenSpan-start span) - (LexerTokenSpan-end span) - (substring (LexerSnapshot-text snapshot) - (LexerTokenSpan-start span) - (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 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 (lookup-lexer-entry snapshot pos) - (define tokens (LexerSnapshot-tokens snapshot)) - (define idx (find-first-token-ending-after tokens pos)) - (and idx - (let ([span (vector-ref tokens idx)]) - (and (<= (LexerTokenSpan-start span) pos) - (lexer-span->public snapshot span))))) - -;; Find the token at `pos`, or the last token before `pos` when `pos` falls -;; between token spans. -(define (find-token-index-at-or-before tokens pos) - (define token-count (vector-length tokens)) - (define idx (find-first-token-ending-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 (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 - (scan-enclosing-paren snapshot tokens (sub1 idx) (add1 depth))] - ['open - (if (positive? depth) - (scan-enclosing-paren snapshot tokens (sub1 idx) (sub1 depth)) - (LexerTokenSpan-start span))] - [_ - (scan-enclosing-paren snapshot tokens (sub1 idx) depth)])])) - -(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-span->public 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-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-entry initial-type 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)]))] - #:when span) - span))) - (LexerSnapshot text (list->vector token-spans))) - -(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 LexerSnapshot? +(provide (struct-out LexerTokenSpan) + (struct-out LexerSnapshot) build-lexer-snapshot + build-lexer-state + LexerState? + LexerState-snapshot + LexerState-language-info + 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 - lexer-snapshot-enclosing-paren-start - lexer-snapshot-next-symbol-start 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 new file mode 100644 index 0000000..91c2c90 --- /dev/null +++ b/doclib/lexer/scan.rkt @@ -0,0 +1,118 @@ +#lang racket/base + +(require "snapshot.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/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 new file mode 100644 index 0000000..72dbc79 --- /dev/null +++ b/doclib/lexer/token-tree.rkt @@ -0,0 +1,216 @@ +#lang racket/base + +(require "snapshot.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-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, 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-List? 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))))) + +(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))) + +(define (non-skippable-node? node) + (not (or (and (Token-Leaf? node) + (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) + (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-List open-span _children _close-span _end) + (LexerTokenSpan-start open-span)] + [(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-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. +(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 + (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 + (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) + (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-List open-span + (reverse children) + close-span + (LexerTokenSpan-end 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? + 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-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..3f99f85 --- /dev/null +++ b/doclib/lexer/tree-query.rkt @@ -0,0 +1,107 @@ +#lang racket/base + +(require "snapshot.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/doclib/service/diagnostic.rkt b/doclib/service/diagnostic.rkt index e976b6f..381fc34 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,11 @@ (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 + (and (requires-language-declaration? src) + (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 +59,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 +97,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-prefix (parse-language-prefix text)) + (cond + [(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-Prefix-text maybe-language-prefix)) #f] + [else + (language-error-diag + (language-prefix-range doc-text maybe-language-prefix) + (unrecognized-language-message maybe-language-prefix))])) + +(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-prefix-range doc-text language-prefix) + (nonempty-diagnostic-range + doc-text + (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-prefix) + (define language-text (Language-Prefix-text language-prefix)) + (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 +194,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 +252,3 @@ #:severity DiagnosticSeverity-Error #:source "Typed Racket" #:message msg)))))) - 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. 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 85557a3..c62318a 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))) @@ -323,27 +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) - (error-response id - ErrorCode-RequestCancelled - "textDocument/semanticTokens request was cancelled because the document closed")] - [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/scribblings/racket-langserver.scrbl b/scribblings/racket-langserver.scrbl index 03f9cc4..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} @@ -699,8 +698,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 new file mode 100644 index 0000000..e554ec1 --- /dev/null +++ b/tests/lib/doc-lang-test.rkt @@ -0,0 +1,265 @@ +#lang racket + +(module+ test + (require rackunit + "../../doclib/doc-lang.rkt" + "../../doclib/lexer.rkt") + + (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)) + + (define (language-name text [uri #f]) + (define language (parse-known-language text uri)) + (and (Known-Language? language) + (Known-Language-name language))) + + (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" + (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-prefix recognizes an ordinary #lang line" + (check-equal? + (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-prefix recognizes #lang reader wrappers" + (check-equal? + (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-prefix keeps the full payload after #lang reader" + (check-equal? + (parse-prefix "#lang reader \"literal.rkt\"\nhello\n") + (prefix 'reader-lang + "\"literal.rkt\"" + (string-length "#lang reader \"literal.rkt\"") + 1)) + (check-equal? + (parse-prefix + "#lang reader (submod syntax/module-reader reader)\n1\n") + (prefix 'reader-lang + "(submod syntax/module-reader reader)" + (string-length + "#lang reader (submod syntax/module-reader reader)") + 1)) + (check-equal? + (parse-prefix "#lang reader (foo)\n1\n") + (prefix 'reader-lang + "(foo)" + (string-length "#lang reader (foo)") + 1))) + + (test-case + "parse-language-prefix recognizes #reader directives" + (check-equal? + (parse-prefix "#reader scribble/reader\n@title{demo}\n") + (prefix 'reader-directive + "scribble/reader" + (string-length "#reader scribble/reader") + 3)) + (check-equal? + (parse-prefix "#reader (reader demo)\nbody\n") + (prefix 'reader-directive + "(reader demo)" + (string-length "#reader (reader demo)") + 7))) + + (test-case + "parse-language-prefix recognizes raw modules" + (check-equal? + (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-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-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-prefix skips leading comments and sexp comments" + (check-equal? + (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-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)") + 0)) + (check-false (parse-prefix "(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) + (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") + 'unrecognized-language) + (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-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 + "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 + "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")) + (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")))) diff --git a/tests/lib/doc-test.rkt b/tests/lib/doc-test.rkt index 4a7a246..c0787f2 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" @@ -88,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)) @@ -106,17 +109,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" " ) (")) @@ -177,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)") @@ -191,10 +213,86 @@ (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 + "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. - (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 @@ -250,9 +348,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 @@ -264,12 +456,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")) @@ -349,8 +541,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 '())))) @@ -686,6 +877,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 +#< (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)) + (define second (lexer-state-body-forest state)) + (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)) + (check-equal? + (token-forest-sexp-comment-spans + (lexer-state-body-forest state)) + '())) + + (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 @@ -49,7 +405,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)) @@ -67,21 +423,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 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/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 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 +#<