From bcb010bbbe6be68bba6e9b0b85c4011132150b20 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Sun, 20 Oct 2024 21:30:14 +0800 Subject: [PATCH 1/4] refactor existing services in doc-trace% --- check-syntax.rkt | 5 +- doc-trace.rkt | 205 ++++++++++++++-------------------------- service/completion.rkt | 27 ++++++ service/declaration.rkt | 82 ++++++++++++++++ service/definition.rkt | 25 +++++ service/diagnostic.rkt | 66 +++++++++++++ service/docs.rkt | 39 ++++++++ service/hover.rkt | 33 +++++++ service/interface.rkt | 35 +++++++ service/require.rkt | 29 ++++++ 10 files changed, 407 insertions(+), 139 deletions(-) create mode 100644 service/completion.rkt create mode 100644 service/declaration.rkt create mode 100644 service/definition.rkt create mode 100644 service/diagnostic.rkt create mode 100644 service/docs.rkt create mode 100644 service/hover.rkt create mode 100644 service/interface.rkt create mode 100644 service/require.rkt diff --git a/check-syntax.rkt b/check-syntax.rkt index 4dee2e8..0e28cca 100644 --- a/check-syntax.rkt +++ b/check-syntax.rkt @@ -179,10 +179,9 @@ (λ () (read-syntax src in)))) ;; 90 seconds limit for possible infinity recursive macro expand (define stx (timeout 90 (expand original-stx))) - (define completions (append (set->list (walk stx)) (set->list (walk-module stx)))) - (send new-trace set-completions completions) + (send new-trace walk-stx original-stx stx) (when trace - (send trace set-completions completions)) + (send trace walk-stx original-stx stx)) (add-syntax stx) (set! valid #t) (done) diff --git a/doc-trace.rkt b/doc-trace.rkt index 31afca3..1a1a798 100644 --- a/doc-trace.rkt +++ b/doc-trace.rkt @@ -1,84 +1,62 @@ #lang racket/base + (require racket/class - racket/dict - racket/set drracket/check-syntax - data/interval-map - net/url - "interfaces.rkt" - "responses.rkt" - "path-util.rkt" - "docs-helpers.rkt" - "struct.rkt") + "service/completion.rkt" + "service/hover.rkt" + "service/docs.rkt" + "service/require.rkt" + "service/definition.rkt" + "service/diagnostic.rkt" + "service/declaration.rkt") (define build-trace% (class (annotations-mixin object%) (init-field src doc-text indenter) - (define warn-diags (mutable-seteq)) - (define hovers (make-interval-map)) - (define docs (make-interval-map)) - (define completions (list)) - (define requires (make-interval-map)) - (define definitions (make-hash)) - (define quickfixs (make-interval-map)) - ;; decl -> (set pos ...) - (define sym-decls (make-interval-map)) - ;; pos -> decl - (define sym-bindings (make-interval-map)) + (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% [doc-text doc-text])) + (define decls (new declaration%)) + + (define services + (list hovers + docs + completions + requires + definitions + diag + decls)) (define/public (reset) - (set-clear! warn-diags) - (set! hovers (make-interval-map)) - (set! docs (make-interval-map)) - (set! sym-decls (make-interval-map)) - (set! sym-bindings (make-interval-map)) - (set! requires (make-interval-map)) - (set! definitions (make-hash)) - (set! quickfixs (make-interval-map))) + (for ([s services]) + (send s reset))) (define/public (expand start end) - (define inc (- end start)) - (move-interior-intervals sym-decls (- start 1) inc) - (move-interior-intervals sym-bindings (- start 1) inc) - (map (lambda (int-map) (interval-map-expand! int-map start end)) - (list hovers docs sym-decls sym-bindings))) + (for ([s services]) + (send s expand start end))) (define/public (contract start end) - (define dec (- start end)) - (move-interior-intervals sym-decls end dec) - (move-interior-intervals sym-bindings end dec) - (map (lambda (int-map) (interval-map-contract! int-map start end)) - (list hovers docs sym-decls sym-bindings))) - - ;; some intervals are held inside of the interval maps... so we need to expand/contract these manually - (define/private (move-interior-intervals int-map after amt) - (dict-for-each int-map - (lambda (range decl-set) - (define result (cond - [(Decl? decl-set) - (define d-range (cons (Decl-left decl-set) (Decl-right decl-set))) - (if (> (car d-range) after) - (Decl (Decl-filename decl-set) #f (+ (car d-range) amt) (+ (cdr d-range) amt)) - #f)] - [else - (list->set (set-map decl-set (lambda (d-range) - (if (> (car d-range) after) - (cons (+ (car d-range) amt) (+ (cdr d-range) amt)) - d-range))))])) - (when result - (interval-map-set! int-map (car range) (cdr range) result))))) + (for ([s services]) + (send s contract start end))) + + (define/public (walk-stx stx expanded-stx) + (for ([s services]) + (send s walk-stx stx expanded-stx))) + ;; Getters (define/public (get-indenter) indenter) - (define/public (get-warn-diags) warn-diags) - (define/public (get-hovers) hovers) - (define/public (get-docs) docs) - (define/public (get-completions) completions) - (define/public (set-completions new-completions) (set! completions new-completions)) - (define/public (get-requires) requires) - (define/public (get-sym-decls) sym-decls) - (define/public (get-sym-bindings) sym-bindings) - (define/public (get-definitions) definitions) - (define/public (get-quickfixs) quickfixs) + (define/public (get-warn-diags) (car (send diag get))) + (define/public (get-hovers) (send hovers get)) + (define/public (get-docs) (send docs get)) + (define/public (get-completions) (send completions get)) + (define/public (get-requires) (send requires get)) + (define/public (get-sym-decls) (car (send decls get))) + (define/public (get-sym-bindings) (cadr (send decls get))) + (define/public (get-definitions) (send definitions get)) + (define/public (get-quickfixs) (cadr (send diag get))) ;; Overrides (define/override (syncheck:find-source-object stx) @@ -86,91 +64,46 @@ src)) ;; Definitions - (define/override (syncheck:add-definition-target _src-obj start end id _mods) - (hash-set! definitions id (Decl src id start end))) + (define/override (syncheck:add-definition-target src-obj start end id mods) + (for ([s services]) + (send s syncheck:add-definition-target src-obj start end id mods))) ;; Track requires - (define/override (syncheck:add-require-open-menu _text start finish file) - (interval-map-set! requires start finish file)) - - ;; Mouse-over status - (define (hint-unused-variable src-obj start finish) - (unless (string=? "_" (send doc-text get-text start (add1 start))) - (define diag (Diagnostic #:range (Range #:start (abs-pos->Pos doc-text start) - #:end (abs-pos->Pos doc-text finish)) - #:severity Diag-Information - #:source (path->uri src-obj) - #:message "unused variable")) - - (interval-map-set! - quickfixs start (add1 finish) - (CodeAction - #:title "Add prefix `_` to ignore" - #:kind "quickfix" - #:diagnostics (list diag) - #:isPreferred #f - #:edit (WorkspaceEdit - #:changes - (hasheq (string->symbol (path->uri src-obj)) - (list (TextEdit #:range (Range #:start (abs-pos->Pos doc-text start) - #:end (abs-pos->Pos doc-text start)) - #:newText "_")))))) - - (set-add! warn-diags diag))) + (define/override (syncheck:add-require-open-menu text start finish file) + (for ([s services]) + (send s syncheck:add-require-open-menu text start finish file))) (define/override (syncheck:add-mouse-over-status src-obj start finish text) - ;; Infer a length of 1 for zero-length ranges in the document. - ;; XXX This might not exactly match the behavior in DrRacket. - (when (= start finish) - (set! finish (add1 finish))) - (when (string=? "no bound occurrences" text) - (hint-unused-variable src-obj start finish)) - (interval-map-set! hovers start finish text)) + (for ([s services]) + (send s syncheck:add-mouse-over-status src-obj start finish text))) ;; Docs - (define/override (syncheck:add-docs-menu _text start finish _id _label path def-tag url-tag) - (when url - (when (= start finish) - (set! finish (add1 finish))) - (define path-url (path->url path)) - (define link+tag (cond - [url-tag (struct-copy url path-url [fragment url-tag])] - [def-tag (struct-copy url path-url [fragment (def-tag->html-anchor-tag def-tag)])] - [else path-url])) - (interval-map-set! docs start finish (list (url->string link+tag) def-tag)))) - - (define/override (syncheck:add-jump-to-definition _src-obj start end id filename _submods) - (define decl (Decl filename id 0 0)) - ;; NOTE start <= end. In some situations, it may be that start = end. - (interval-map-set! sym-bindings start (if (= start end) (add1 end) end) decl)) + (define/override (syncheck:add-docs-menu text start finish id label path def-tag url-tag) + (for ([s services]) + (send s syncheck:add-docs-menu text start finish id label path def-tag url-tag))) + + (define/override (syncheck:add-jump-to-definition src-obj start end id filename submods) + (for ([s services]) + (send s syncheck:add-jump-to-definition src-obj start end id filename submods))) ;; References (define/override (syncheck:add-arrow/name-dup _start-src-obj start-left start-right _end-src-obj end-left end-right _actual? _phase-level require-arrow? _name-dup?) - (when (= start-left start-right) - (set! start-right (add1 start-right))) - (when (= end-left end-right) - (set! end-right (add1 end-right))) - ;; Mapping from doc declaration to set of bindings. - (define prev-bindings (interval-map-ref sym-decls start-left set)) - (define new-bindings (set-add prev-bindings (cons end-left end-right))) - (interval-map-set! sym-decls start-left start-right new-bindings) - ;; Mapping from binding to declaration. - (unless require-arrow? - (define new-decl (Decl #f #f start-left start-right)) - (interval-map-set! sym-bindings end-left end-right new-decl))) + (for ([s services]) + (send s syncheck:add-arrow/name-dup + _start-src-obj start-left start-right + _end-src-obj end-left end-right + _actual? _phase-level + require-arrow? _name-dup?))) ;; Unused requires - (define/override (syncheck:add-unused-require _src left right) - (define diag (Diagnostic #:range (Range #:start (abs-pos->Pos doc-text left) - #:end (abs-pos->Pos doc-text right)) - #:severity Diag-Information - #:source "Racket" - #:message "unused require")) - (set-add! warn-diags diag)) + (define/override (syncheck:add-unused-require src left right) + (for ([s services]) + (send s syncheck:add-unused-require src left right))) (super-new))) (provide build-trace%) + diff --git a/service/completion.rkt b/service/completion.rkt new file mode 100644 index 0000000..0e64b7c --- /dev/null +++ b/service/completion.rkt @@ -0,0 +1,27 @@ +#lang racket/base + +(require "interface.rkt" + "../autocomplete.rkt" + racket/class + racket/set) + +(provide completion%) + +(define completion% + (class base-service% + (super-new) + (define completions (list)) + + (define/override (get) + completions) + + (define/override (reset) + (set! completions (list))) + + (define/override (walk-stx stx expanded-stx) + (define c (append (set->list (walk expanded-stx)) + (set->list (walk-module expanded-stx)))) + (set! completions c)) + + )) + diff --git a/service/declaration.rkt b/service/declaration.rkt new file mode 100644 index 0000000..f0a4f2c --- /dev/null +++ b/service/declaration.rkt @@ -0,0 +1,82 @@ +#lang racket/base + +(require "interface.rkt" + racket/class + "../struct.rkt" + data/interval-map + racket/dict + racket/set + drracket/check-syntax) + +(provide declaration%) + +(define declaration% + (class base-service% + (super-new) + ;; decl -> (set pos ...) + (define sym-decls (make-interval-map)) + ;; pos -> decl + (define sym-bindings (make-interval-map)) + + (define/override (get) + (list sym-decls sym-bindings)) + + (define/override (reset) + (set! sym-decls (make-interval-map)) + (set! sym-bindings (make-interval-map))) + + (define/override (expand start end) + (define inc (- end start)) + (move-interior-intervals sym-decls (- start 1) inc) + (move-interior-intervals sym-bindings (- start 1) inc) + (map (lambda (int-map) (interval-map-expand! int-map start end)) + (list sym-decls sym-bindings))) + + (define/override (contract start end) + (define dec (- start end)) + (move-interior-intervals sym-decls end dec) + (move-interior-intervals sym-bindings end dec) + (map (lambda (int-map) (interval-map-contract! int-map start end)) + (list sym-decls sym-bindings))) + + ;; some intervals are held inside of the interval maps... so we need to expand/contract these manually + (define/private (move-interior-intervals int-map after amt) + (dict-for-each int-map + (lambda (range decl-set) + (define result (cond + [(Decl? decl-set) + (define d-range (cons (Decl-left decl-set) (Decl-right decl-set))) + (if (> (car d-range) after) + (Decl (Decl-filename decl-set) #f (+ (car d-range) amt) (+ (cdr d-range) amt)) + #f)] + [else + (list->set (set-map decl-set (lambda (d-range) + (if (> (car d-range) after) + (cons (+ (car d-range) amt) (+ (cdr d-range) amt)) + d-range))))])) + (when result + (interval-map-set! int-map (car range) (cdr range) result))))) + + (define/override (syncheck:add-jump-to-definition _src-obj start end id filename _submods) + (define decl (Decl filename id 0 0)) + ;; NOTE start <= end. In some situations, it may be that start = end. + (interval-map-set! sym-bindings start (if (= start end) (add1 end) end) decl)) + + (define/override (syncheck:add-arrow/name-dup _start-src-obj start-left start-right + _end-src-obj end-left end-right + _actual? _phase-level + require-arrow? _name-dup?) + (when (= start-left start-right) + (set! start-right (add1 start-right))) + (when (= end-left end-right) + (set! end-right (add1 end-right))) + ;; Mapping from doc declaration to set of bindings. + (define prev-bindings (interval-map-ref sym-decls start-left set)) + (define new-bindings (set-add prev-bindings (cons end-left end-right))) + (interval-map-set! sym-decls start-left start-right new-bindings) + ;; Mapping from binding to declaration. + (unless require-arrow? + (define new-decl (Decl #f #f start-left start-right)) + (interval-map-set! sym-bindings end-left end-right new-decl))) + )) + diff --git a/service/definition.rkt b/service/definition.rkt new file mode 100644 index 0000000..9893341 --- /dev/null +++ b/service/definition.rkt @@ -0,0 +1,25 @@ +#lang racket/base + +(require "interface.rkt" + racket/class + "../struct.rkt" + drracket/check-syntax) + +(provide definition%) + +(define definition% + (class base-service% + (init-field src) + (super-new) + + (define definitions (make-hash)) + + (define/override (get) + definitions) + + (define/override (reset) + (set! definitions (make-hash))) + + (define/override (syncheck:add-definition-target _src-obj start end id _mods) + (hash-set! definitions id (Decl src id start end))))) + diff --git a/service/diagnostic.rkt b/service/diagnostic.rkt new file mode 100644 index 0000000..e141635 --- /dev/null +++ b/service/diagnostic.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +(require "interface.rkt" + racket/class + racket/set + data/interval-map + "../interfaces.rkt" + "../responses.rkt" + "../path-util.rkt" + drracket/check-syntax) + +(provide diag%) + +(define diag% + (class base-service% + (init-field doc-text) + (super-new) + + (define warn-diags (mutable-seteq)) + (define quickfixs (make-interval-map)) + + (define/override (get) + (list warn-diags quickfixs)) + + (define/override (reset) + (set-clear! warn-diags) + (set! quickfixs (make-interval-map))) + + (define/override (syncheck:add-mouse-over-status src-obj start finish text) + (when (string=? "no bound occurrences" text) + (hint-unused-variable src-obj start finish))) + + ;; Mouse-over status + (define (hint-unused-variable src-obj start finish) + (unless (string=? "_" (send doc-text get-text start (add1 start))) + (define diag + (Diagnostic #:range (Range #:start (abs-pos->Pos doc-text start) + #:end (abs-pos->Pos doc-text finish)) + #:severity Diag-Information + #:source (path->uri src-obj) + #:message "unused variable")) + + (define code-action + (CodeAction + #:title "Add prefix `_` to ignore" + #:kind "quickfix" + #:diagnostics (list diag) + #:isPreferred #f + #:edit (WorkspaceEdit + #:changes + (hasheq (string->symbol (path->uri src-obj)) + (list (TextEdit #:range (Range #:start (abs-pos->Pos doc-text start) + #:end (abs-pos->Pos doc-text start)) + #:newText "_")))))) + + (interval-map-set! quickfixs start (add1 finish) code-action) + (set-add! warn-diags diag))) + + (define/override (syncheck:add-unused-require _src left right) + (define diag (Diagnostic #:range (Range #:start (abs-pos->Pos doc-text left) + #:end (abs-pos->Pos doc-text right)) + #:severity Diag-Information + #:source "Racket" + #:message "unused require")) + (set-add! warn-diags diag)))) + diff --git a/service/docs.rkt b/service/docs.rkt new file mode 100644 index 0000000..cc3434b --- /dev/null +++ b/service/docs.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +(require "interface.rkt" + racket/class + "../docs-helpers.rkt" + data/interval-map + net/url + drracket/check-syntax) + +(provide docs%) + +(define docs% + (class base-service% + (super-new) + (define docs (make-interval-map)) + + (define/override (get) + docs) + + (define/override (reset) + (set! docs (make-interval-map))) + + (define/override (expand start end) + (interval-map-expand! docs start end)) + + (define/override (contract start end) + (interval-map-contract! docs start end)) + + (define/override (syncheck:add-docs-menu _text start finish _id _label path def-tag url-tag) + (when url + (when (= start finish) + (set! finish (add1 finish))) + (define path-url (path->url path)) + (define link+tag (cond + [url-tag (struct-copy url path-url [fragment url-tag])] + [def-tag (struct-copy url path-url [fragment (def-tag->html-anchor-tag def-tag)])] + [else path-url])) + (interval-map-set! docs start finish (list (url->string link+tag) def-tag)))))) + diff --git a/service/hover.rkt b/service/hover.rkt new file mode 100644 index 0000000..e295d3b --- /dev/null +++ b/service/hover.rkt @@ -0,0 +1,33 @@ +#lang racket/base + +(require "interface.rkt" + racket/class + data/interval-map + drracket/check-syntax) + +(provide hover%) + +(define hover% + (class base-service% + (super-new) + (define hovers (make-interval-map)) + + (define/override (get) + hovers) + + (define/override (reset) + (set! hovers (make-interval-map))) + + (define/override (expand start end) + (interval-map-expand! hovers start end)) + + (define/override (contract start end) + (interval-map-contract! hovers start end)) + + (define/override (syncheck:add-mouse-over-status src-obj start finish text) + ;; Infer a length of 1 for zero-length ranges in the document. + ;; XXX This might not exactly match the behavior in DrRacket. + (when (= start finish) + (set! finish (add1 finish))) + (interval-map-set! hovers start finish text)))) + diff --git a/service/interface.rkt b/service/interface.rkt new file mode 100644 index 0000000..da39164 --- /dev/null +++ b/service/interface.rkt @@ -0,0 +1,35 @@ +#lang racket/base + +(require racket/class + drracket/check-syntax) + +(provide service<%> + base-service%) + +(define service<%> + (interface (syncheck-annotations<%>) + get + expand + contract + reset + walk)) + +(define base-service% + (class (annotations-mixin object%) + (super-new) + + (define/public (get) + #f) + + (define/public (expand start end) + (void)) + + (define/public (contract start end) + (void)) + + (define/public (reset) + (void)) + + (define/public (walk-stx stx expanded-stx) + (void)))) + diff --git a/service/require.rkt b/service/require.rkt new file mode 100644 index 0000000..b72c8e1 --- /dev/null +++ b/service/require.rkt @@ -0,0 +1,29 @@ +#lang racket/base + +(require "interface.rkt" + racket/class + data/interval-map + drracket/check-syntax) + +(provide require%) + +(define require% + (class base-service% + (super-new) + (define requires (make-interval-map)) + + (define/override (get) + requires) + + (define/override (reset) + (set! requires (make-interval-map))) + + (define/override (expand start end) + (interval-map-expand! requires start end)) + + (define/override (contract start end) + (interval-map-contract! requires start end)) + + (define/override (syncheck:add-require-open-menu _text start finish file) + (interval-map-set! requires start finish file)))) + From 616f837427af695e4323f3f55a0f9856281d6462 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Fri, 25 Oct 2024 01:06:08 +0800 Subject: [PATCH 2/4] merge highlight into services make all services work in more unified way. --- check-syntax.rkt | 27 +- doc-trace.rkt | 12 +- doc.rkt | 153 +++---- lock.rkt | 40 ++ methods.rkt | 36 +- scheduler.rkt | 71 ++++ highlight.rkt => service/highlight.rkt | 83 ++-- tests/textDocument/formatting.rkt | 3 +- text-document.rkt | 550 ++++++++++++++----------- 9 files changed, 598 insertions(+), 377 deletions(-) create mode 100644 lock.rkt rename highlight.rkt => service/highlight.rkt (73%) diff --git a/check-syntax.rkt b/check-syntax.rkt index 0e28cca..39ab52f 100644 --- a/check-syntax.rkt +++ b/check-syntax.rkt @@ -13,7 +13,6 @@ "editor.rkt" "responses.rkt" "interfaces.rkt" - "autocomplete.rkt" "doc-trace.rkt") (define ((error-diagnostics doc-text) exn) @@ -137,12 +136,11 @@ (define-syntax-rule (timeout time-sec body) (with-limits time-sec #f body)) -(define (check-syntax src doc-text trace) +(define (check-syntax src doc-text) (define indenter (get-indenter doc-text)) (define ns (make-base-namespace)) (define new-trace (new build-trace% [src src] [doc-text doc-text] [indenter indenter])) - (match-define-values (src-dir _ #f) - (split-path src)) + (match-define-values (src-dir _ #f) (split-path src)) (define-values (add-syntax done) (make-traversal ns src-dir)) @@ -150,8 +148,6 @@ (define text (send doc-text get-text)) (define in (open-input-string text)) (port-count-lines! in) - (when trace - (set-clear! (send trace get-warn-diags))) (define valid #f) (define lang-diag (if (eq? indenter 'missing) @@ -166,9 +162,9 @@ [current-namespace ns] [current-load-relative-directory src-dir]) (with-intercepted-logging - (lambda (l) - (define result (check-typed-racket-log doc-text l)) - (when (list? result) (set! diags (append result diags)))) + (lambda (l) + (define result (check-typed-racket-log doc-text l)) + (when (list? result) (set! diags (append result diags)))) (lambda () (with-handlers ([(or/c exn:fail:read? exn:fail:syntax? @@ -179,22 +175,21 @@ (λ () (read-syntax src in)))) ;; 90 seconds limit for possible infinity recursive macro expand (define stx (timeout 90 (expand original-stx))) - (send new-trace walk-stx original-stx stx) - (when trace - (send trace walk-stx original-stx stx)) (add-syntax stx) (set! valid #t) (done) + (send new-trace walk-stx original-stx stx) (list))) 'info))) (define warn-diags (send new-trace get-warn-diags)) ;; reuse old trace if check-syntax failed - (list (if valid new-trace (or trace new-trace)) + (list (if valid new-trace #f) (append err-diags (set->list warn-diags) lang-diag diags))) (provide - (contract-out - [check-syntax (-> any/c (is-a?/c lsp-editor%) (or/c #f (is-a?/c build-trace%)) - (list/c (is-a?/c build-trace%) any/c))])) + (contract-out + [check-syntax (-> any/c (is-a?/c lsp-editor%) + (list/c (or/c #f (is-a?/c build-trace%)) any/c))])) + diff --git a/doc-trace.rkt b/doc-trace.rkt index 1a1a798..f3431e4 100644 --- a/doc-trace.rkt +++ b/doc-trace.rkt @@ -8,7 +8,8 @@ "service/require.rkt" "service/definition.rkt" "service/diagnostic.rkt" - "service/declaration.rkt") + "service/declaration.rkt" + "service/highlight.rkt") (define build-trace% (class (annotations-mixin object%) @@ -20,6 +21,7 @@ (define definitions (new definition% [src src])) (define diag (new diag% [doc-text doc-text])) (define decls (new declaration%)) + (define semantic-tokens (new highlight% [src src] [doc-text doc-text])) (define services (list hovers @@ -28,7 +30,8 @@ requires definitions diag - decls)) + decls + semantic-tokens)) (define/public (reset) (for ([s services]) @@ -57,6 +60,7 @@ (define/public (get-sym-bindings) (cadr (send decls get))) (define/public (get-definitions) (send definitions get)) (define/public (get-quickfixs) (cadr (send diag get))) + (define/public (get-semantic-tokens) (send semantic-tokens get)) ;; Overrides (define/override (syncheck:find-source-object stx) @@ -103,6 +107,10 @@ (for ([s services]) (send s syncheck:add-unused-require src left right))) + (define/override (syncheck:color-range src start end style) + (for ([s services]) + (send s syncheck:color-range src start end style))) + (super-new))) (provide build-trace%) diff --git a/doc.rkt b/doc.rkt index d3e47d4..b8b67e4 100644 --- a/doc.rkt +++ b/doc.rkt @@ -9,7 +9,6 @@ "path-util.rkt" "doc-trace.rkt" "struct.rkt" - "highlight.rkt" racket/match racket/class racket/set @@ -21,47 +20,69 @@ syntax-color/racket-lexer json drracket/check-syntax - syntax/modread) + syntax/modread + "lock.rkt") + +;; SafeDoc has two eliminator: +;; 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. +(struct SafeDoc + (doc rwlock) + #:transparent) (struct Doc - (text - trace - uri - during-batch-change? - checked?) - #:transparent #:mutable) + (uri text trace version trace-version) + #:mutable) -(define (send-diagnostics doc diag-lst) - (display-message/flush (diagnostics-message (Doc-uri doc) diag-lst))) +(define (send-diagnostics uri diag-lst) + (display-message/flush (diagnostics-message uri diag-lst))) ;; the only place where really run check-syntax -(define (doc-run-check-syntax doc) - (define (task) - (set-Doc-checked?! doc #f) - (match-define (list new-trace diags) - (check-syntax (uri->path (Doc-uri doc)) (Doc-text doc) (Doc-trace doc))) - (send-diagnostics doc diags) - (set-Doc-trace! doc new-trace) - - (set-Doc-checked?! doc #t)) - - (scheduler-push-task! (Doc-uri doc) task)) +(define (doc-run-check-syntax! safe-doc) + (match-define (list uri old-version text) + (with-read-doc safe-doc + (λ (doc) + (list (Doc-uri doc) (Doc-version doc) (send (Doc-text doc) copy))))) -(define (lazy-check-syntax doc) - (when (not (Doc-during-batch-change? doc)) - (doc-run-check-syntax doc))) - -(define (doc-checked? doc) - (Doc-checked? doc)) - -(define (new-doc uri text) + (define (task) + (match-define (list new-trace diags) (check-syntax (uri->path uri) text)) + ;; make a new thread to write doc because this task will be executed by + ;; the scheduler and can be killed at any time. + (thread + (λ () + (send-diagnostics uri diags) + (with-write-doc safe-doc + (λ (doc) + (when (and (equal? old-version (Doc-version doc)) + new-trace) + (set-Doc-trace-version! doc old-version) + (set-Doc-trace! doc new-trace)))) + (clear-old-queries/new-trace uri)))) + + (scheduler-push-task! (with-read-doc safe-doc (λ (doc) (Doc-uri doc))) task)) + +(define (new-doc uri text version) (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 (Doc doc-text doc-trace uri #f #f)) - (lazy-check-syntax doc) - doc) + (define doc (Doc uri doc-text doc-trace version #f)) + (define safe-doc (SafeDoc doc (make-rwlock))) + safe-doc) + +(define (doc-update-version! doc new-ver) + (set-Doc-version! doc new-ver)) + +(define (with-read-doc safe-doc proc) + (call-with-read-lock + (SafeDoc-rwlock safe-doc) + (λ () (proc (SafeDoc-doc safe-doc))))) + +(define (with-write-doc safe-doc proc) + (call-with-write-lock + (SafeDoc-rwlock safe-doc) + (λ () (proc (SafeDoc-doc safe-doc))))) (define (doc-reset! doc new-text) (define doc-text (Doc-text doc)) @@ -69,8 +90,7 @@ (send doc-text erase) (send doc-trace reset) - (send doc-text insert new-text 0) - (lazy-check-syntax doc)) + (send doc-text insert new-text 0)) (define (doc-update! doc st-ln st-ch ed-ln ed-ch text) (define doc-text (Doc-text doc)) @@ -85,15 +105,7 @@ ;; and return the old build-trace% object (cond [(> new-len old-len) (send doc-trace expand end-pos (+ st-pos new-len))] [(< new-len old-len) (send doc-trace contract (+ st-pos new-len) end-pos)]) - (send doc-text replace text st-pos end-pos) - (lazy-check-syntax doc)) - -(define-syntax-rule (doc-batch-change doc expr ...) - (let () - (set-Doc-during-batch-change?! doc #t) - expr ... - (set-Doc-during-batch-change?! doc #f) - (lazy-check-syntax doc))) + (send doc-text replace text st-pos end-pos)) (define (doc-pos doc line ch) (send (Doc-text doc) line/char->pos line ch)) @@ -210,16 +222,16 @@ ;; formatting ;; ;; Shared path for all formatting requests -(define (format! this-doc st-ln st-ch ed-ln ed-ch +(define (format! doc st-ln st-ch ed-ln ed-ch #:on-type? [on-type? #f] #:formatting-options opts) - (define doc-text (Doc-text this-doc)) - (define doc-trace (Doc-trace this-doc)) + (define doc-text (Doc-text doc)) + (define doc-trace (Doc-trace doc)) (define indenter (send doc-trace get-indenter)) - (define start-pos (doc-pos this-doc st-ln st-ch)) + (define start-pos (doc-pos doc st-ln st-ch)) ;; Adjust for line endings (#92) - (define end-pos (max start-pos (sub1 (doc-pos this-doc ed-ln ed-ch)))) + (define end-pos (max start-pos (sub1 (doc-pos doc ed-ln ed-ch)))) (define start-line (send doc-text at-line start-pos)) (define end-line (send doc-text at-line end-pos)) @@ -245,16 +257,16 @@ (if (> line end-line) null (append (filter-map - values - ;; NOTE: The order is important here. - ;; `remove-trailing-space!` deletes content relative to the initial document - ;; position. If we were to instead call `indent-line!` first and then - ;; `remove-trailing-space!` second, the remove step could result in - ;; losing user entered code. - (list (if (false? (FormattingOptions-trim-trailing-whitespace opts)) - #f - (remove-trailing-space! mut-doc-text skip-this-line? line)) - (indent-line! mut-doc-text indenter-wp line))) + values + ;; NOTE: The order is important here. + ;; `remove-trailing-space!` deletes content relative to the initial document + ;; position. If we were to instead call `indent-line!` first and then + ;; `remove-trailing-space!` second, the remove step could result in + ;; losing user entered code. + (list (if (false? (FormattingOptions-trim-trailing-whitespace opts)) + #f + (remove-trailing-space! mut-doc-text skip-this-line? line)) + (indent-line! mut-doc-text indenter-wp line))) (loop (add1 line))))))) (define (replace-tab! doc-text line tabsize) @@ -287,7 +299,7 @@ (define to (string-length line-text)) (send doc-text replace-in-line "" line from to) (TextEdit #:range (Range #:start (Pos #:line line #:char from) - #:end (Pos #:line line #:char to)) + #:end (Pos #:line line #:char to)) #:newText "")] [else #f])) @@ -340,7 +352,7 @@ ;; ;; each token is encoded as five integers (copied from lsp specificatioin 3.17): ;; * deltaLine: token line number, relative to the start of the previous token -;; * deltaStart: token start character, relative to the start of the previous token +;; * deltaStart: token start character, relative to the start of the previous token ;; (relative to 0 or the previous token’s start if they are on the same line) ;; * length: the length of the token. ;; * tokenType: will be looked up in SemanticTokensLegend.tokenTypes. @@ -349,9 +361,9 @@ ;; ;; for the first token, its previous token is defined as a zero length fake token which ;; has line number 0 and character position 0. -(define (token-encoding editor token prev-pos) - (match-define (list line ch) (send editor pos->line/char (SemanticToken-start token))) - (match-define (list prev-line prev-ch) (send editor pos->line/char prev-pos)) +(define (token-encoding doc token prev-pos) + (match-define (list line ch) (send (Doc-text doc) pos->line/char (SemanticToken-start token))) + (match-define (list prev-line prev-ch) (send (Doc-text doc) pos->line/char prev-pos)) (define delta-line (- line prev-line)) (define delta-start (if (= line prev-line) @@ -366,8 +378,8 @@ ;; the tokens whose range intersects the given range is included. ;; the previous token of the first token in the result is defined as a zero length fake token which ;; has line number 0 and character position 0. -(define (doc-range-tokens editor uri pos-start pos-end) - (define tokens (collect-semantic-tokens editor (uri->path uri))) +(define (doc-range-tokens doc pos-start pos-end) + (define tokens (send (Doc-trace doc) get-semantic-tokens)) (define tokens-in-range (filter-not (λ (tok) (or (<= (SemanticToken-end tok) pos-start) (>= (SemanticToken-start tok) pos-end))) @@ -377,17 +389,18 @@ #:result (flatten (reverse result))) ([token tokens-in-range]) (define-values (delta-line delta-start len type modifier) - (token-encoding editor token prev-pos)) + (token-encoding doc token prev-pos)) (values (cons (list delta-line delta-start len type modifier) result) (SemanticToken-start token)))) -(provide Doc-text - Doc-trace +(provide with-read-doc + with-write-doc + (struct-out Doc) new-doc - doc-checked? doc-update! doc-reset! - doc-batch-change + doc-update-version! + doc-run-check-syntax! doc-pos doc-endpos doc-line/ch diff --git a/lock.rkt b/lock.rkt new file mode 100644 index 0000000..5ce0e8b --- /dev/null +++ b/lock.rkt @@ -0,0 +1,40 @@ +#lang racket/base + +;; A Readers Writer Lock +(struct RWLock + (sema wsema readers) + #:mutable) + +(define (make-rwlock) + (RWLock (make-semaphore 1) (make-semaphore 1) 0)) + +(define (call-with-read-lock rwlock proc) + (define sema (RWLock-sema rwlock)) + (define write (RWLock-wsema rwlock)) + + (semaphore-wait sema) + (when (= 0 (RWLock-readers rwlock)) + (semaphore-wait write)) + (set-RWLock-readers! rwlock (add1 (RWLock-readers rwlock))) + (semaphore-post sema) + + (define results (call-with-values proc list)) + + (semaphore-wait sema) + (set-RWLock-readers! rwlock (sub1 (RWLock-readers rwlock))) + (when (= 0 (RWLock-readers rwlock)) + (semaphore-post write)) + (semaphore-post sema) + (apply values results)) + +(define (call-with-write-lock rwlock proc) + (define write (RWLock-wsema rwlock)) + (semaphore-wait write) + (define results (call-with-values proc list)) + (semaphore-post write) + (apply values results)) + +(provide make-rwlock + call-with-read-lock + call-with-write-lock) + diff --git a/methods.rkt b/methods.rkt index 713a021..06b2bc1 100644 --- a/methods.rkt +++ b/methods.rkt @@ -9,6 +9,36 @@ "struct.rkt" (prefix-in text-document/ "text-document.rkt")) +;; Process a request or an notification. +;; +;; A request asks for a result. A notification can optionally +;; send some information to the client. +;; +;; A process can return result then send to client, or return +;; a procedure that is a async task and is expected to run in +;; a new thread. +;; +;; Most requests and notifications can be simplified into two types: +;; +;; Text change: for example, document change notification +;; Queries: Read only requests +;; +;; For a text change, we do a fast and simple adjustment synchronously to the data in +;; build-trace% which is defined in `doc-trace.rkt`. This fast adjustment is useful for +;; fast response, but can be incorrect. So we also runs an async task (check syntax) +;; to update the build-trace%, which can be very slow and sometimes failed, but it +;; is correct. +;; +;; For a query, if it's not important to use the latest data, we just run it synchronously +;; and use the fast adjusted build-trace%. Otherwise, it would be an async task. We choose +;; to run it right before the next text change event or after the current text corresponding +;; check syntax task completes. +;; +;; One important point is that check syntax task is computationally intensive, so don't run +;; too much. The current strategy is an newer check syntax task always replace +;; the old running task. So for any document, at most one check syntax task is running +;; at any time. + ;; TextDocumentSynKind enumeration (define TextDocSync-None 0) (define TextDocSync-Full 1) @@ -175,7 +205,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide - (contract-out - [process-message - (jsexpr? . -> . void?)])) + (contract-out + [process-message + (jsexpr? . -> . void?)])) diff --git a/scheduler.rkt b/scheduler.rkt index e5dbd96..c0596c6 100644 --- a/scheduler.rkt +++ b/scheduler.rkt @@ -3,6 +3,8 @@ (require racket/async-channel racket/match) +;; schedule check syntax + (define incoming-jobs-ch (make-async-channel)) ;; new incoming task will replace the old task immediately @@ -27,3 +29,72 @@ (async-channel-put incoming-jobs-ch (cons path task))) (provide scheduler-push-task!) + +;; schedule queries + +;; All awaiting queries are run before next document change +;; or after a new check syntax is completed. + +(define *await-queries* (make-hash)) +(define *await-queries-semaphore* (make-semaphore 1)) + +(struct QuerySignal + ()) + +(define *doc-change-signal* (QuerySignal)) +(define *new-trace-signal* (QuerySignal)) + +(define (signal-doc-change? s) + (eq? s *doc-change-signal*)) + +(define (signal-new-trace? s) + (eq? s *new-trace-signal*)) + +(define (run-and-remove-queries uri signal) + (for ([data (hash-ref *await-queries* uri '())]) + (match-define (list task ch) data) + (async-channel-put ch (task signal))) + (hash-remove! *await-queries* uri)) + +(define (async-query-wait uri task) + (define query-ch (make-async-channel)) + (call-with-semaphore + *await-queries-semaphore* + (λ () + (hash-update! *await-queries* + uri + (λ (old) (cons (list task query-ch) old)) + '()))) + + (λ () (sync query-ch))) + +;; send doc change event signal and waiting for all waiting queries +;; to be processed. +(define (clear-old-queries/doc-change uri) + (call-with-semaphore + *await-queries-semaphore* + (λ () + (run-and-remove-queries uri *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 uri) + (call-with-semaphore + *await-queries-semaphore* + (λ () + (run-and-remove-queries uri *new-trace-signal*)))) + +;; remove all await queries +(define (clear-old-queries/doc-close uri) + (call-with-semaphore + *await-queries-semaphore* + (λ () + (hash-remove! *await-queries* uri)))) + +(provide async-query-wait + signal-doc-change? + signal-new-trace? + clear-old-queries/doc-change + clear-old-queries/new-trace + clear-old-queries/doc-close) + diff --git a/highlight.rkt b/service/highlight.rkt similarity index 73% rename from highlight.rkt rename to service/highlight.rkt index 09e4c83..cd3778e 100644 --- a/highlight.rkt +++ b/service/highlight.rkt @@ -2,31 +2,36 @@ (require drracket/check-syntax syntax/parse - "struct.rkt" + "../struct.rkt" racket/class - racket/set racket/list racket/bool + racket/dict racket/match - "expand.rkt") + data/interval-map + "interface.rkt") -(provide collect-semantic-tokens) +(provide highlight%) -;; A temporary structure to hold tokens -;; `tag` is symbol that is a tag associated with this token. -;; An identifier may correspond multiple tokens. They will be merged, then converted into -;; lsp semantic token types and modifiers. -(struct Token - (start end tag)) - -(define collector% - (class (annotations-mixin object%) +(define highlight% + (class base-service% + (super-new) + (init-field src doc-text) (define styles '()) + (define token-map (make-interval-map)) - (super-new) + (define/override (get) + (interval-map->token-lst token-map)) + + (define/override (reset) + (set! styles '()) + (set! token-map (make-interval-map))) + + (define/override (expand start end) + (interval-map-expand! token-map start end)) - (define/override (syncheck:find-source-object stx) - #f) + (define/override (contract start end) + (interval-map-contract! token-map start end)) (define/override (syncheck:color-range src start end style) (when (< start end) @@ -36,23 +41,35 @@ (when (< start finish) (set! styles (cons (Token start finish 'definition) styles)))) - (define/public (get-styles) - (set->list (list->set styles))))) + (define/override (walk-stx stx expanded) + (set! token-map (token-list->interval-map (collect-tokens stx expanded styles src doc-text)))) -; (-> lsp-editor% Path (Listof SemanticToken)) -(define (collect-semantic-tokens doc-text path) - (define code-str (send doc-text get-text)) - (define in (open-input-string code-str)) - (port-count-lines! in) + (define (token-list->interval-map lst) + (define interval-map (make-interval-map)) + (for ([tok lst]) + (interval-map-set! interval-map (SemanticToken-start tok) (SemanticToken-end tok) tok)) + interval-map) + + (define (interval-map->token-lst token-map) + (for/list ([(k v) (in-dict token-map)]) + (SemanticToken (car k) (cdr k) (SemanticToken-type v) (SemanticToken-modifiers v)))) + )) + +;; A temporary structure to hold tokens +;; `tag` is symbol that is a tag associated with this token. +;; An identifier may correspond multiple tokens. They will be merged, then converted into +;; lsp semantic token types and modifiers. +(struct Token + (start end tag)) - (define collector (new collector%)) - (match-define (list stx expanded) (sync (read-and-expand in path collector))) - (define drracket-styles (convert-drracket-color-styles (send collector get-styles))) +(define (collect-tokens stx expanded styles src doc-text) + (define drracket-styles (convert-drracket-color-styles styles)) + (define code-str (send doc-text get-text)) (define token-list (append drracket-styles - (if (syntax? stx) (walk-stx stx) '()) - (if (syntax? expanded) (walk-expanded-stx path expanded) '()))) + (if (syntax? stx) (walk-orig-stx stx) '()) + (if (syntax? expanded) (walk-expanded-stx src expanded) '()))) (let* ([tokens-no-false (filter-not false? token-list)] [tokens-no-out-bounds (filter (λ (t) (< -1 (Token-start t) (string-length code-str))) @@ -95,16 +112,16 @@ (define (get-valid-modifiers tags) (filter (λ (t) (memq t *semantic-token-modifiers*)) tags)) -(define (walk-stx stx) +(define (walk-orig-stx stx) (syntax-parse stx #:datum-literals (#%module-begin) [() (list)] [(any1 any* ...) - (append (walk-stx #'any1) - (walk-stx #'(any* ...)))] + (append (walk-orig-stx #'any1) + (walk-orig-stx #'(any* ...)))] [#(any1 any* ...) - (append (walk-stx #'any1) - (walk-stx #'(any* ...)))] + (append (walk-orig-stx #'any1) + (walk-orig-stx #'(any* ...)))] [#%module-begin (list)] [atom (list (tag-of-atom-stx #'atom))])) diff --git a/tests/textDocument/formatting.rkt b/tests/textDocument/formatting.rkt index fab6e54..1aa6d9c 100644 --- a/tests/textDocument/formatting.rkt +++ b/tests/textDocument/formatting.rkt @@ -21,7 +21,8 @@ END (let ([notif (make-notification "textDocument/didChange" (hasheq 'textDocument - (hasheq 'uri uri) + (hasheq 'uri uri + 'version 0) 'contentChanges (list (hasheq 'range diff --git a/text-document.rkt b/text-document.rkt index 7a4530b..35010e9 100644 --- a/text-document.rkt +++ b/text-document.rkt @@ -18,7 +18,8 @@ "docs-helpers.rkt" "documentation-parser.rkt" "doc.rkt" - "struct.rkt") + "struct.rkt" + "scheduler.rkt") ;; ;; Match Expanders @@ -78,33 +79,41 @@ (define open-docs (make-hasheq)) (define (did-open! params) - (match-define (hash-table ['textDocument (DocItem #:uri uri #:text text)]) params) - (hash-set! open-docs (string->symbol uri) - (new-doc uri text))) + (match-define (hash-table ['textDocument (DocItem #:uri uri #:version version #:text text)]) params) + (define safe-doc (new-doc uri text version)) + (hash-set! open-docs (string->symbol uri) safe-doc) + (doc-run-check-syntax! safe-doc)) (define (did-close! params) (match-define (hash-table ['textDocument (DocItem #:uri uri)]) params) - (hash-remove! open-docs (string->symbol uri))) + (hash-remove! open-docs (string->symbol uri)) + (clear-old-queries/doc-close uri)) (define (did-change! params) - (match-define (hash-table ['textDocument (DocIdentifier #:uri uri)] + (match-define (hash-table ['textDocument (DocIdentifier #:version version #:uri uri)] ['contentChanges content-changes]) params) - (define this-doc (hash-ref open-docs (string->symbol uri))) + (define safe-doc (hash-ref open-docs (string->symbol uri))) (define content-changes* (cond [(eq? (json-null) content-changes) empty] [(list? content-changes) content-changes] [else (list content-changes)])) - (doc-batch-change this-doc - (for ([change (in-list content-changes*)]) - (match change - [(ContentChangeEvent #:range (Range #:start (Pos #:line st-ln #:char st-ch) - #:end (Pos #:line ed-ln #:char ed-ch)) - #:text text) - (doc-update! this-doc st-ln st-ch ed-ln ed-ch text)] - [(ContentChangeEvent #:text text) - (doc-reset! this-doc text)]))) - (void)) + (clear-old-queries/doc-change uri) + + (with-write-doc safe-doc + (λ (doc) + (for ([change (in-list content-changes*)]) + (match change + [(ContentChangeEvent #:range (Range #:start (Pos #:line st-ln #:char st-ch) + #:end (Pos #:line ed-ln #:char ed-ch)) + #:text text) + (doc-update! doc st-ln st-ch ed-ln ed-ch text)] + [(ContentChangeEvent #:text text) + (doc-reset! doc text)])) + + (doc-update-version! doc version))) + + (doc-run-check-syntax! safe-doc)) ;; Hover request ;; Returns an object conforming to the Hover interface, to @@ -113,51 +122,52 @@ (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)] ['position (Pos #:line line #:char ch)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define doc-trace (Doc-trace this-doc)) - - (define hovers (send doc-trace get-hovers)) - (define pos (doc-pos this-doc line ch)) - (define-values (start end text) - (interval-map-ref/bounds hovers pos #f)) - (match-define (list link tag) - (interval-map-ref (send doc-trace get-docs) pos (list #f #f))) - (define result - (cond [text - ;; We want signatures from `scribble/blueboxes` as they have better indentation, - ;; but in some super rare cases blueboxes aren't accessible, thus we try to use the - ;; parsed signature instead - (match-define (list sigs args-descr) - (if tag - (get-docs-for-tag tag) - (list #f #f))) - (define maybe-signature - (if sigs - (~a "```\n" - (string-join sigs "\n") - (if args-descr (~a "\n" args-descr) "") - "\n```\n---\n") - #f)) - (define documentation-text - (if link - (~a (or maybe-signature "") - (or (extract-documentation-for-selected-element - link #:include-signature? (not maybe-signature)) - "")) - "")) - (define contents (if link - (~a text - " - [online docs](" - (make-proper-url-for-online-documentation link) - ")\n" - (if (non-empty-string? documentation-text) - (~a "\n---\n" documentation-text) - "")) - text)) - (hasheq 'contents contents - 'range (start/end->range this-doc start end))] - [else (hasheq 'contents empty)])) - (success-response id result)] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (define doc-trace (Doc-trace doc)) + (define hovers (send doc-trace get-hovers)) + (define pos (doc-pos doc line ch)) + (define-values (start end text) + (interval-map-ref/bounds hovers pos #f)) + (match-define (list link tag) + (interval-map-ref (send doc-trace get-docs) pos (list #f #f))) + (define result + (cond [text + ;; We want signatures from `scribble/blueboxes` as they have better indentation, + ;; but in some super rare cases blueboxes aren't accessible, thus we try to use the + ;; parsed signature instead + (match-define (list sigs args-descr) + (if tag + (get-docs-for-tag tag) + (list #f #f))) + (define maybe-signature + (if sigs + (~a "```\n" + (string-join sigs "\n") + (if args-descr (~a "\n" args-descr) "") + "\n```\n---\n") + #f)) + (define documentation-text + (if link + (~a (or maybe-signature "") + (or (extract-documentation-for-selected-element + link #:include-signature? (not maybe-signature)) + "")) + "")) + (define contents (if link + (~a text + " - [online docs](" + (make-proper-url-for-online-documentation link) + ")\n" + (if (non-empty-string? documentation-text) + (~a "\n---\n" documentation-text) + "")) + text)) + (hasheq 'contents contents + 'range (start/end->range doc start end))] + [else (hasheq 'contents empty)])) + (success-response id result)))] [_ (error-response id INVALID-PARAMS "textDocument/hover failed")])) @@ -171,12 +181,15 @@ ; 2. `only: CodeActionKind[]` server should use this to filter out client-unwanted code action ; 3. `triggerKind?: CodeActionTriggerKind` the reason why code action were requested ['context _ctx]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define doc-trace (Doc-trace this-doc)) - - (define act (interval-map-ref (send doc-trace get-quickfixs) - (pos->abs-pos this-doc start) - #f)) + (define safe-doc (hash-ref open-docs (string->symbol uri))) + + (define act + (with-read-doc safe-doc + (λ (doc) + (define doc-trace (Doc-trace doc)) + (interval-map-ref (send doc-trace get-quickfixs) + (pos->abs-pos doc start) + #f)))) (if act (success-response id (list act)) (success-response id (list)))] @@ -190,34 +203,36 @@ (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)] ['position (Pos #:line line #:char ch)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define doc-trace (Doc-trace this-doc)) - - (define pos (doc-pos this-doc line ch)) - (define new-pos (doc-find-containing-paren this-doc (- pos 1))) - (define result - (cond [new-pos - (define maybe-tag (interval-map-ref (send doc-trace get-docs) (+ new-pos 1) #f)) - (define tag - (cond [maybe-tag (last maybe-tag)] - [else - (define symbols (doc-get-symbols this-doc)) - (define-values (start end symbol) - (interval-map-ref/bounds symbols (+ new-pos 2) #f)) - (cond [symbol - (id-to-tag (first symbol) doc-trace)] - [else #f])])) - (cond [tag - (match-define (list sigs docs) (get-docs-for-tag tag)) - (if sigs - (hasheq 'signatures (map (lambda (sig) - (hasheq 'label sig - 'documentation (or docs (json-null)))) - sigs)) - (json-null))] - [else (json-null)])] - [else (json-null)])) - (success-response id result)] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (define doc-trace (Doc-trace doc)) + + (define pos (doc-pos doc line ch)) + (define new-pos (doc-find-containing-paren doc (- pos 1))) + (define result + (cond [new-pos + (define maybe-tag (interval-map-ref (send doc-trace get-docs) (+ new-pos 1) #f)) + (define tag + (cond [maybe-tag (last maybe-tag)] + [else + (define symbols (doc-get-symbols doc)) + (define-values (start end symbol) + (interval-map-ref/bounds symbols (+ new-pos 2) #f)) + (cond [symbol + (id-to-tag (first symbol) doc-trace)] + [else #f])])) + (cond [tag + (match-define (list sigs docs) (get-docs-for-tag tag)) + (if sigs + (hasheq 'signatures (map (lambda (sig) + (hasheq 'label sig + 'documentation (or docs (json-null)))) + sigs)) + (json-null))] + [else (json-null)])] + [else (json-null)])) + (success-response id result)))] [_ (error-response id INVALID-PARAMS "textDocument/signatureHelp failed")])) @@ -226,14 +241,15 @@ (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)] ['position (Pos #:line line #:char ch)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define doc-trace (Doc-trace this-doc)) - - (define completions (send doc-trace get-completions)) - (define result - (for/list ([completion (in-list completions)]) - (hasheq 'label (symbol->string completion)))) - (success-response id result)] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (define doc-trace (Doc-trace doc)) + (define completions (send doc-trace get-completions)) + (define result + (for/list ([completion (in-list completions)]) + (hasheq 'label (symbol->string completion)))) + (success-response id result)))] [_ (error-response id INVALID-PARAMS "textDocument/completion failed")])) @@ -245,17 +261,19 @@ ['position (Pos #:line line #:char char)]) (define-values (start end decl) (get-decl uri line char)) - (define this-doc (hash-ref open-docs (string->symbol uri))) + (define safe-doc (hash-ref open-docs (string->symbol uri))) (define result - (match decl - [#f (json-null)] - [(Decl #f id start end) - (Location #:uri uri - #:range (start/end->range this-doc start end))] - [(Decl path id 0 0) - (Location #:uri (path->uri path) - #:range (Range->hash (get-definition-by-id path id)))])) + (with-read-doc safe-doc + (λ (doc) + (match decl + [#f (json-null)] + [(Decl #f id start end) + (Location #:uri uri + #:range (start/end->range doc start end))] + [(Decl path id 0 0) + (Location #:uri (path->uri path) + #:range (Range->hash (get-definition-by-id path id)))])))) (success-response id result)] [_ (error-response id INVALID-PARAMS "textDocument/definition failed")])) @@ -268,19 +286,21 @@ ['context (hash-table ['includeDeclaration include-decl?])]) (define-values (start end decl) (get-decl uri line char)) - (define this-doc (hash-ref open-docs (string->symbol uri))) + (define safe-doc (hash-ref open-docs (string->symbol uri))) (define result - (match decl - [(Decl req? id left right) - (define ranges - (if req? - (list (start/end->range this-doc start end) - (start/end->range this-doc left right)) - (or (get-bindings uri decl)))) - (for/list ([range (in-list ranges)]) - (hasheq 'uri uri 'range range))] - [#f (json-null)])) + (with-read-doc safe-doc + (λ (doc) + (match decl + [(Decl req? id left right) + (define ranges + (if req? + (list (start/end->range doc start end) + (start/end->range doc left right)) + (or (get-bindings uri decl)))) + (for/list ([range (in-list ranges)]) + (hasheq 'uri uri 'range range))] + [#f (json-null)])))) (success-response id result)] [_ (error-response id INVALID-PARAMS "textDocument/references failed")])) @@ -291,21 +311,23 @@ [(hash-table ['textDocument (DocIdentifier #:uri uri)] ['position (Pos #:line line #:char char)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) + (define safe-doc (hash-ref open-docs (string->symbol uri))) (define-values (start end decl) (get-decl uri line char)) (define result - (match decl - [(Decl filename id left right) - (define ranges - (if filename - (list (start/end->range this-doc start end) - (start/end->range this-doc left right)) - (or (append (get-bindings uri decl) - (list (start/end->range this-doc left right)))))) - (for/list ([range (in-list ranges)]) - (hasheq 'range range))] - [#f (json-null)])) + (with-read-doc safe-doc + (λ (doc) + (match decl + [(Decl filename id left right) + (define ranges + (if filename + (list (start/end->range doc start end) + (start/end->range doc left right)) + (or (append (get-bindings uri decl) + (list (start/end->range doc left right)))))) + (for/list ([range (in-list ranges)]) + (hasheq 'range range))] + [#f (json-null)])))) (success-response id result)] [_ (error-response id INVALID-PARAMS "textDocument/documentHighlight failed")])) @@ -321,18 +343,20 @@ (define this-doc (hash-ref open-docs (string->symbol uri))) (define result - (match decl - [(Decl req? id left right) - (cond [req? (json-null)] - [else - (define ranges (cons (start/end->range this-doc left right) - (get-bindings uri decl))) - (WorkspaceEdit - #:changes - (hasheq (string->symbol uri) - (for/list ([range (in-list ranges)]) - (TextEdit #:range range #:newText new-name))))])] - [#f (json-null)])) + (with-read-doc this-doc + (λ (doc) + (match decl + [(Decl req? id left right) + (cond [req? (json-null)] + [else + (define ranges (cons (start/end->range doc left right) + (get-bindings uri decl))) + (WorkspaceEdit + #:changes + (hasheq (string->symbol uri) + (for/list ([range (in-list ranges)]) + (TextEdit #:range range #:newText new-name))))])] + [#f (json-null)])))) (success-response id result)] [_ (error-response id INVALID-PARAMS "textDocument/documentHighlight failed")])) @@ -347,7 +371,7 @@ (define this-doc (hash-ref open-docs (string->symbol uri))) (if (and decl (not (Decl-filename decl))) - (success-response id (start/end->range this-doc start end)) + (success-response id (with-read-doc this-doc (λ (doc) (start/end->range doc start end)))) (success-response id (json-null)))] [_ (error-response id INVALID-PARAMS "textDocument/documentHighlight failed")])) @@ -357,59 +381,65 @@ ;; the declaration. If #:include-decl is 'all, the list includes the declaration ;; and all bound occurrences. (define (get-bindings uri decl) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define doc-trace (Doc-trace this-doc)) - - (define doc-decls (send doc-trace get-sym-decls)) - (match-define (Decl req? id left right) decl) - (define-values (bind-start bind-end bindings) - (interval-map-ref/bounds doc-decls left #f)) - (if bindings - (for/list ([range (in-set bindings)]) - (start/end->range this-doc (car range) (cdr range))) - empty)) + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (define doc-trace (Doc-trace doc)) + + (define doc-decls (send doc-trace get-sym-decls)) + (match-define (Decl req? id left right) decl) + (define-values (bind-start bind-end bindings) + (interval-map-ref/bounds doc-decls left #f)) + (if bindings + (for/list ([range (in-set bindings)]) + (start/end->range doc (car range) (cdr range))) + empty)))) (define (get-decl uri line char) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define doc-trace (Doc-trace this-doc)) - - (define pos (doc-pos this-doc line char)) - (define doc-decls (send doc-trace get-sym-decls)) - (define doc-bindings (send doc-trace get-sym-bindings)) - (define-values (start end maybe-decl) - (interval-map-ref/bounds doc-bindings pos #f)) - (define-values (bind-start bind-end maybe-bindings) - (interval-map-ref/bounds doc-decls pos #f)) - (if maybe-decl - (values start end maybe-decl) - (if maybe-bindings - (values bind-start - bind-end - (interval-map-ref doc-bindings (car (set-first maybe-bindings)) #f)) - (values #f #f #f)))) + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (define doc-trace (Doc-trace doc)) + + (define pos (doc-pos doc line char)) + (define doc-decls (send doc-trace get-sym-decls)) + (define doc-bindings (send doc-trace get-sym-bindings)) + (define-values (start end maybe-decl) + (interval-map-ref/bounds doc-bindings pos #f)) + (define-values (bind-start bind-end maybe-bindings) + (interval-map-ref/bounds doc-decls pos #f)) + (if maybe-decl + (values start end maybe-decl) + (if maybe-bindings + (values bind-start + bind-end + (interval-map-ref doc-bindings (car (set-first maybe-bindings)) #f)) + (values #f #f #f)))))) ;; Document Symbol request (define (document-symbol id params) (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) + (define safe-doc (hash-ref open-docs (string->symbol uri))) (define results - (dict-map (doc-get-symbols this-doc) - (λ (key value) - (match-define (cons start end) key) - (match-define (list text type) value) - (define kind (match type - ['constant SymbolKind-Constant] - ['string SymbolKind-String] - ['symbol SymbolKind-Variable])) - (define range - (Range #:start (abs-pos->pos this-doc start) - #:end (abs-pos->pos this-doc end))) - (SymbolInfo #:name text - #:kind kind - #:location (Location #:uri uri - #:range range))))) + (with-read-doc safe-doc + (λ (doc) + (dict-map (doc-get-symbols doc) + (λ (key value) + (match-define (cons start end) key) + (match-define (list text type) value) + (define kind (match type + ['constant SymbolKind-Constant] + ['string SymbolKind-String] + ['symbol SymbolKind-Variable])) + (define range + (Range #:start (abs-pos->pos doc start) + #:end (abs-pos->pos doc end))) + (SymbolInfo #:name text + #:kind kind + #:location (Location #:uri uri + #:range range))))))) (success-response id results)] [_ (error-response id INVALID-PARAMS "textDocument/documentSymbol failed")])) @@ -418,7 +448,7 @@ (define (inlay-hint id params) (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)] - ['range (Range #:start start #:end end)]) + ['range (Range #:start start #:end end)]) (success-response id '())] [_ (error-response id INVALID-PARAMS "textDocument/inlayHint failed")])) @@ -428,11 +458,12 @@ [(hash-table ['textDocument (DocIdentifier #:uri uri)] ['options (as-FormattingOptions opts)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - - (define-values (st-ln st-ch) (doc-line/ch this-doc 0)) - (define-values (ed-ln ed-ch) (doc-line/ch this-doc (doc-endpos this-doc))) - (success-response id (format! this-doc st-ln st-ch ed-ln ed-ch #:formatting-options opts))] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (define-values (st-ln st-ch) (doc-line/ch doc 0)) + (define-values (ed-ln ed-ch) (doc-line/ch doc (doc-endpos doc))) + (success-response id (format! doc st-ln st-ch ed-ln ed-ch #:formatting-options opts))))] [_ (error-response id INVALID-PARAMS "textDocument/formatting failed")])) @@ -440,11 +471,13 @@ (define (range-formatting! id params) (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)] - ['range (Range #:start (Pos #:line st-ln #:char st-ch) - #:end (Pos #:line ed-ln #:char ed-ch))] + ['range (Range #:start (Pos #:line st-ln #:char st-ch) + #:end (Pos #:line ed-ln #:char ed-ch))] ['options (as-FormattingOptions opts)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (success-response id (format! this-doc st-ln st-ch ed-ln ed-ch #:formatting-options opts))] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (with-read-doc safe-doc + (λ (doc) + (success-response id (format! doc st-ln st-ch ed-ln ed-ch #:formatting-options opts))))] [_ (error-response id INVALID-PARAMS "textDocument/rangeFormatting failed")])) @@ -458,31 +491,33 @@ ['position (Pos #:line line #:char char)] ['ch ch] ['options (as-FormattingOptions opts)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - - (define ch-pos (- (doc-pos this-doc line char) 1)) - (define-values (st-ln st-ch ed-ln ed-ch) - (match ch - ["\n" - (define-values (st-ln st-ch) (doc-line/ch this-doc (doc-line-start-pos this-doc line))) - (define-values (ed-ln ed-ch) (doc-line/ch this-doc (doc-line-end-pos this-doc line))) - (values st-ln st-ch ed-ln ed-ch)] - [_ - (define-values (st-ln st-ch) - (doc-line/ch this-doc (or (doc-find-containing-paren this-doc (max 0 (sub1 ch-pos))) 0))) - (define-values (ed-ln ed-ch) (doc-line/ch this-doc ch-pos)) - (values st-ln st-ch ed-ln ed-ch)])) - (success-response id (format! this-doc st-ln st-ch ed-ln ed-ch - #:on-type? #t - #:formatting-options opts))] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + + (with-read-doc safe-doc + (λ (doc) + (define ch-pos (- (doc-pos doc line char) 1)) + (define-values (st-ln st-ch ed-ln ed-ch) + (match ch + ["\n" + (define-values (st-ln st-ch) (doc-line/ch doc (doc-line-start-pos doc line))) + (define-values (ed-ln ed-ch) (doc-line/ch doc (doc-line-end-pos doc line))) + (values st-ln st-ch ed-ln ed-ch)] + [_ + (define-values (st-ln st-ch) + (doc-line/ch doc (or (doc-find-containing-paren doc (max 0 (sub1 ch-pos))) 0))) + (define-values (ed-ln ed-ch) (doc-line/ch doc ch-pos)) + (values st-ln st-ch ed-ln ed-ch)])) + (success-response id (format! doc st-ln st-ch ed-ln ed-ch + #:on-type? #t + #:formatting-options opts))))] [_ (error-response id INVALID-PARAMS "textDocument/onTypeFormatting failed")])) (define (full-semantic-tokens id params) (match params [(hash-table ['textDocument (DocIdentifier #:uri uri)]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (semantic-tokens uri id 0 (doc-endpos this-doc))] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (semantic-tokens uri id safe-doc 0 (with-read-doc safe-doc (λ (doc) (doc-endpos doc))))] [_ (error-response id INVALID-PARAMS "textDocument/semanticTokens/full failed")])) (define (range-semantic-tokens id params) @@ -490,40 +525,51 @@ [(hash-table ['textDocument (DocIdentifier #:uri uri)] ['range (Range #:start (Pos #:line st-ln #:char st-ch) #:end (Pos #:line ed-ln #:char ed-ch))]) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define start-pos (doc-pos this-doc st-ln st-ch)) - (define end-pos (doc-pos this-doc ed-ln ed-ch)) - (semantic-tokens uri id start-pos end-pos)] + (define safe-doc (hash-ref open-docs (string->symbol uri))) + (match-define (list start-pos end-pos) + (with-read-doc safe-doc + (λ (doc) + (list (doc-pos doc st-ln st-ch) + (doc-pos doc ed-ln ed-ch))))) + (semantic-tokens uri id safe-doc start-pos end-pos)] [_ (error-response id INVALID-PARAMS "textDocument/semanticTokens/range failed")])) -(define (semantic-tokens uri id start-pos end-pos) - (define this-doc (hash-ref open-docs (string->symbol uri))) - (define new-editor (send (Doc-text this-doc) copy)) - (λ () - (define tokens (doc-range-tokens new-editor uri start-pos end-pos)) - (success-response id (hash 'data tokens)))) +(define (semantic-tokens uri id safe-doc start-pos end-pos) + (define tokens + (with-read-doc safe-doc + (λ (doc) + (if (equal? (Doc-version doc) (Doc-trace-version doc)) + (doc-range-tokens doc start-pos end-pos) + #f)))) + (if tokens + (success-response id (hash 'data tokens)) + (async-query-wait + uri + (λ (_signal) + (define tokens (with-read-doc safe-doc (λ (doc) (doc-range-tokens doc start-pos end-pos)))) + (success-response id (hash 'data tokens)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide - (contract-out - [did-open! (jsexpr? . -> . void?)] - [did-close! (jsexpr? . -> . void?)] - [did-change! (jsexpr? . -> . void?)] - [hover (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [code-action (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [completion (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [signatureHelp (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [definition (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [document-highlight (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [references (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [document-symbol (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [inlay-hint (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [rename _rename rename (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [prepareRename (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [range-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [on-type-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] - [full-semantic-tokens (exact-nonnegative-integer? jsexpr? . -> . (or/c jsexpr? (-> jsexpr?)))] - [range-semantic-tokens (exact-nonnegative-integer? jsexpr? . -> . (or/c jsexpr? (-> jsexpr?)))])) + (contract-out + [did-open! (jsexpr? . -> . void?)] + [did-close! (jsexpr? . -> . void?)] + [did-change! (jsexpr? . -> . void?)] + [hover (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [code-action (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [completion (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [signatureHelp (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [definition (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [document-highlight (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [references (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [document-symbol (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [inlay-hint (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [rename _rename rename (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [prepareRename (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [range-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [on-type-formatting! (exact-nonnegative-integer? jsexpr? . -> . jsexpr?)] + [full-semantic-tokens (exact-nonnegative-integer? jsexpr? . -> . (or/c jsexpr? (-> jsexpr?)))] + [range-semantic-tokens (exact-nonnegative-integer? jsexpr? . -> . (or/c jsexpr? (-> jsexpr?)))])) From 58f043f37f6edffc4115325095a56fa2fb65e5bf Mon Sep 17 00:00:00 2001 From: 6cdh Date: Fri, 25 Oct 2024 12:51:07 +0800 Subject: [PATCH 3/4] fix: fix service interface and small style improvement --- lock.rkt | 16 ++++++++-------- service/interface.rkt | 11 +++++++++-- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/lock.rkt b/lock.rkt index 5ce0e8b..c05b261 100644 --- a/lock.rkt +++ b/lock.rkt @@ -2,33 +2,33 @@ ;; A Readers Writer Lock (struct RWLock - (sema wsema readers) + (access-sema write-sema readers) #:mutable) (define (make-rwlock) (RWLock (make-semaphore 1) (make-semaphore 1) 0)) (define (call-with-read-lock rwlock proc) - (define sema (RWLock-sema rwlock)) - (define write (RWLock-wsema rwlock)) + (define access (RWLock-access-sema rwlock)) + (define write (RWLock-write-sema rwlock)) - (semaphore-wait sema) + (semaphore-wait access) (when (= 0 (RWLock-readers rwlock)) (semaphore-wait write)) (set-RWLock-readers! rwlock (add1 (RWLock-readers rwlock))) - (semaphore-post sema) + (semaphore-post access) (define results (call-with-values proc list)) - (semaphore-wait sema) + (semaphore-wait access) (set-RWLock-readers! rwlock (sub1 (RWLock-readers rwlock))) (when (= 0 (RWLock-readers rwlock)) (semaphore-post write)) - (semaphore-post sema) + (semaphore-post access) (apply values results)) (define (call-with-write-lock rwlock proc) - (define write (RWLock-wsema rwlock)) + (define write (RWLock-write-sema rwlock)) (semaphore-wait write) (define results (call-with-values proc list)) (semaphore-post write) diff --git a/service/interface.rkt b/service/interface.rkt index da39164..89842f0 100644 --- a/service/interface.rkt +++ b/service/interface.rkt @@ -12,24 +12,31 @@ expand contract reset - walk)) + walk-stx)) (define base-service% - (class (annotations-mixin object%) + (class* (annotations-mixin object%) + (service<%> syncheck-annotations<%>) + (super-new) + ;; return data (define/public (get) #f) + ;; insert text between from start to end (exclusive) (define/public (expand start end) (void)) + ;; delete text between from start to end (exclusive) (define/public (contract start end) (void)) + ;; clear all content (define/public (reset) (void)) + ;; walk original syntax and expanded syntax (define/public (walk-stx stx expanded-stx) (void)))) From f5cb021178c01b225b3de48508ffd89abfad1dc0 Mon Sep 17 00:00:00 2001 From: 6cdh Date: Tue, 29 Oct 2024 20:25:30 +0800 Subject: [PATCH 4/4] rename lock.rkt to rwlock.rkt and move it to base directory --- lock.rkt => base/rwlock.rkt | 0 doc.rkt | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename lock.rkt => base/rwlock.rkt (100%) diff --git a/lock.rkt b/base/rwlock.rkt similarity index 100% rename from lock.rkt rename to base/rwlock.rkt diff --git a/doc.rkt b/doc.rkt index b8b67e4..44bafb2 100644 --- a/doc.rkt +++ b/doc.rkt @@ -21,7 +21,7 @@ json drracket/check-syntax syntax/modread - "lock.rkt") + "base/rwlock.rkt") ;; SafeDoc has two eliminator: ;; with-read-doc: access Doc within a reader lock.