scheme-langserver/protocol/analysis/request-queue.sls at main · MoganLab/scheme-langserver · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
(library (scheme-langserver protocol analysis request-queue)
  (export
    make-request-queue
    request-queue-pop
    request-queue-push
    request-queue-empty?)
  (import
    (chezscheme)
    (slib queue)

    (scheme-langserver util association)
    (scheme-langserver protocol request)
    (scheme-langserver analysis workspace))

(define-record-type request-queue
  (fields
    (immutable mutex)
    (immutable condition)
    (immutable queue)
    (mutable tickal-task-list))
  (protocol
    (lambda (new)
      (lambda ()
        (new (make-mutex) (make-condition) (make-queue) '())))))

;ticks is an empirical constant for Chez Scheme's engine time-slicing.
;It bounds how many abstract instructions a single task may execute before
;entering the expire callback.  The value 100000 was chosen to let typical
;LSP requests finish in one slice while forcing long-running analysis
;(e.g. type inference) to yield periodically so that cancellation can be checked.
(define ticks 100000)

(define-record-type tickal-task
  (fields
    (immutable request)
    (mutable stop?)
    (immutable expire)
    (immutable complete))
  (protocol
    ; Must have request-queue-mutex
    (lambda (new)
      (lambda (request request-queue workspace)
        (let ([new-task #f])
          (letrec ([complete
                (lambda (ticks value)
                  (remove:from-request-tickal-task-list request-queue new-task)
                  value)]
            ; This expire mainly aims to interrupt type inference, so that acquires workspace mutex.
            ; It shouldn't be supposed that it interrupt the workspace refreshing procedure.
              [expire
                (lambda (remains)
                  (cond
                    [(or
                        (string=? "textDocument/didChange" (request-method request))
                        (string=? "textDocument/didOpen" (request-method request))
                        (string=? "textDocument/didClose" (request-method request)))
                      (remains ticks complete expire)]
                    [(tickal-task-stop? new-task)
                      (with-mutex (workspace-mutex workspace)
                        (remove:from-request-tickal-task-list request-queue new-task))]
                    [else (remains ticks complete expire)]))])
            (set! new-task (new request #f expire complete))
            (enqueue! (request-queue-queue request-queue) new-task)
            (request-queue-tickal-task-list-set!
              request-queue
              (cons new-task (request-queue-tickal-task-list request-queue)))
            new-task))))))

(define (request-queue-empty? queue)
  (with-mutex (request-queue-mutex queue)
    (queue-empty? (request-queue-queue queue))))

(define (request-queue-pop queue request-processor)
  (with-mutex (request-queue-mutex queue)
    (let loop ()
      (when (queue-empty? (request-queue-queue queue))
        ; By default, this will release request-queue-mutex
        ; and re-enter when request-queue-condition is signed.
        (condition-wait (request-queue-condition queue) (request-queue-mutex queue))
        (loop)))
    (let* ([task (dequeue! (request-queue-queue queue))]
        [request (tickal-task-request task)]
        [job (lambda ()
          (if (tickal-task-stop? task)
            (remove:from-request-tickal-task-list queue task)
            (request-processor request)))])
      ; May be called in the consumer thread or directly
      (lambda () ((make-engine job) ticks (tickal-task-complete task) (tickal-task-expire task))))))

(define (remove:from-request-tickal-task-list queue task)
  (with-mutex (request-queue-mutex queue)
    (request-queue-tickal-task-list-set!
      queue
      (remq task (request-queue-tickal-task-list queue)))))

(define (request-queue-push queue request potential-request-processor workspace)
  (with-mutex (request-queue-mutex queue)
    (case (request-method request)
      ["private:publish-diagnostics"
        (let* ([predicator (lambda (task) (string=? "private:publish-diagnostics" (request-method (tickal-task-request task))))]
            [tickal-task (find predicator (request-queue-tickal-task-list queue))])
          (when (not tickal-task)
            (make-tickal-task request queue workspace)))]
      ["$/cancelRequest"
        (let ([id (assq-ref (request-params request) 'id)])
          (when id
            (let* ([predicator (lambda (task) (equal? id (request-id (tickal-task-request task))))]
                [tickal-task (find predicator (request-queue-tickal-task-list queue))])
              ; Mark the target task as cancelled. Its expire callback will
              ; remove it from the tickal-task-list when the engine slice ends.
              (when tickal-task
                (tickal-task-stop?-set! tickal-task #t)))))]
      ["textDocument/didChange"
        (make-tickal-task request queue workspace)]
      [else (make-tickal-task request queue workspace)])
      ; Because the pool is limited to have only one thread.
      (condition-signal (request-queue-condition queue))))
)