Improve Resyntax integration (#196)

* Remove doc-walk-text call in doc-expand!

* Remove walk-text methods

* Make resyntax integration a independent module

* Add Resyntax related functions to doc.rkt

* Allow doc-code-action also return resyntax's result

* Add more resyntax test

* Add doc-resyntax-available? function to doc lib

* Allow runs resyntax through places

* Improve the exception handlers by only capture specific exceptions

This allows break exception are handled correctly by outer handlers.

* Disable resyntax test when it's not available

* format resyntax test file

* Make doc-diagnostics also return resyntax results

* Clear saved resyntax results after each edit

* Update scribble docs

* Use a fallback slower version of interval-map-iterate-least/end>? in old Racket versions

Author: 6cdh

doclib/service/dynamic-import.rkt common/dynamic-import.rktdoclib/service/dynamic-import.rkt renamed to common/dynamic-import.rkt

@@ -7,9 +7,9 @@
     (let ([logging-fail-thunk (λ ()
                                 (log-info "symbol '~a' from module '~a' fail to load." 'name mod)
                                 (fail-thunk))])
-      (with-handlers ([exn? (λ (e)
-                              (logging-fail-thunk)
-                              (void))])
+      (with-handlers ([exn:fail? (λ (_e)
+                                   (logging-fail-thunk)
+                                   (void))])
         (dynamic-require mod 'name logging-fail-thunk)))))
 
 (define-syntax-rule (dynamic-import-mod mod names ... fail-thunk)
@@ -19,4 +19,3 @@
 (define-syntax-rule (dynamic-imports (mod names ...) ... fail-thunk)
   (begin
     (dynamic-import-mod mod names ... fail-thunk) ...))
-

common/interfaces.rkt

@@ -16,6 +16,7 @@
 
 (provide (json-type-out Pos)
          (json-type-out Range)
+         char-range-intersect?
          (json-type-out TextEdit)
          (json-type-out WorkspaceEdit)
          (json-type-out CodeAction)
@@ -53,7 +54,8 @@
          (struct-out SemanticToken)
          *semantic-token-types*
          *semantic-token-modifiers*
-         abs-pos->Pos)
+         abs-pos->Pos
+         (json-type-out Resyntax-Result))
 
 (define-json-struct Pos
   [line exact-nonnegative-integer?]
@@ -63,6 +65,15 @@
   [start Pos]
   [end Pos])
 
+(define/contract (char-range-intersect? left-start left-end right-start right-end)
+  (-> exact-nonnegative-integer?
+      exact-nonnegative-integer?
+      exact-nonnegative-integer?
+      exact-nonnegative-integer?
+      boolean?)
+  (and (< left-start right-end)
+       (< right-start left-end)))
+
 (define-json-struct TextEdit
   [range Range]
   [newText string?])
@@ -275,3 +286,11 @@
   (match-define (list line char) (send editor pos->line/char pos))
   (Pos #:line line #:char char))
 
+;; Resyntax-Result: result of a resyntax refactoring suggestion
+(define-json-struct Resyntax-Result
+  [start exact-nonnegative-integer?]
+  [end exact-nonnegative-integer?]
+  [message string?]
+  [rule-name symbol?]
+  [new-text string?])
+

doclib/autocomplete.rkt

@@ -15,7 +15,7 @@
 (define (walk stx)
   (append
     (set->list (user-defined:walk stx))
-    (with-handlers ([(λ (_exn) #t) (λ (_) '())])
+    (with-handlers ([exn:fail? (λ (_) '())])
       (set->list (required:walk-module stx)))))
 
 ;; Get completions that will be computed for every text change.

doclib/check-syntax.rkt

@@ -39,7 +39,7 @@
                  [current-namespace ns]
                  [current-annotations collector])
     (define stx
-      (with-handlers ([(λ _ #t) (λ (exn) exn)])
+      (with-handlers ([exn:fail? (λ (exn) exn)])
         (with-module-reading-parameterization
           (λ () (read-syntax path in)))))
 
@@ -48,7 +48,7 @@
       (with-intercepted-logging
         (λ (log) (set! expand-logs (cons log expand-logs)))
         (λ ()
-          (with-handlers ([(λ _ #t) (λ (exn) exn)])
+          (with-handlers ([exn:fail? (λ (exn) exn)])
             (parameterize ([current-output-port (open-output-nowhere)])
               (if (syntax? stx)
                   (expand stx)

doclib/doc-trace.rkt

@@ -52,10 +52,6 @@
       (for ([s services])
         (send s walk-stx expand-result)))
 
-    (define/public (walk-text text)
-      (for ([s services])
-        (send s walk-text text)))
-
     (define/public (walk-log text)
       (for ([s services])
         (send s walk-log text)))

doclib/doc.rkt

@@ -22,6 +22,7 @@
          syntax-color/module-lexer
          syntax-color/racket-lexer
          "check-syntax.rkt"
+         "external/resyntax.rkt"
          "docs-helpers.rkt"
          "documentation-parser.rkt"
          drracket/check-syntax
@@ -32,7 +33,8 @@
    [text (is-a?/c lsp-editor%)]
    [trace (is-a?/c build-trace%)]
    [version exact-nonnegative-integer?]
-   [trace-version (or/c false/c exact-nonnegative-integer?)])
+   [trace-version (or/c false/c exact-nonnegative-integer?)]
+   [resyntax-results (listof Resyntax-Result?)])
   #:mutable)
 
 (define/contract (make-doc uri text [version 0])
@@ -43,7 +45,57 @@
   (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]))
-  (Doc uri doc-text doc-trace version #f))
+  (Doc uri doc-text doc-trace version #f (list)))
+
+(define (invalidate-resyntax-results! doc)
+  (set-Doc-resyntax-results! doc (list)))
+
+(define/contract (doc-get-resyntax-results doc)
+  (-> Doc? (listof Resyntax-Result?))
+  (Doc-resyntax-results doc))
+
+(define/contract (doc-update-resyntax-result! doc results)
+  (-> Doc? (listof Resyntax-Result?) void?)
+  (set-Doc-resyntax-results! doc results))
+
+(define/contract (resyntax-result->diag doc res)
+  (-> Doc? Resyntax-Result? Diagnostic?)
+  (define range
+    (Range #:start (doc-abs-pos->pos doc (Resyntax-Result-start res))
+           #:end (doc-abs-pos->pos doc (Resyntax-Result-end res))))
+  (Diagnostic #:range range
+              #:severity DiagnosticSeverity-Information
+              #:source "Resyntax"
+              #:message (format "[~a] ~a" (Resyntax-Result-rule-name res) (Resyntax-Result-message res))))
+
+(define/contract (resyntax-result->code-action doc res)
+  (-> Doc? Resyntax-Result? CodeAction?)
+  (define diag (resyntax-result->diag doc res))
+  (define doc-uri (Doc-uri doc))
+  (define range (Diagnostic-range diag))
+  (CodeAction
+    #:title (format "Apply rule [~a]" (Resyntax-Result-rule-name res))
+    #:kind "quickfix"
+    #:diagnostics (list diag)
+    #:isPreferred #f
+    #:edit (WorkspaceEdit
+             #:changes
+             (hasheq (string->symbol doc-uri)
+                     (list (TextEdit #:range range
+                                     #:newText (Resyntax-Result-new-text res)))))))
+
+(define/contract (doc-resyntax doc)
+  (-> Doc? (listof Resyntax-Result?))
+  (run-resyntax (send (Doc-text doc) get-text) (Doc-uri doc)))
+
+(define/contract (doc-resyntax! doc)
+  (-> Doc? void?)
+  (define results (doc-resyntax doc))
+  (doc-update-resyntax-result! doc results))
+
+(define/contract (doc-resyntax-available?)
+  (-> boolean?)
+  (resyntax-available?))
 
 (define/contract (doc-update-version! doc new-ver)
   (-> Doc? exact-nonnegative-integer? void?)
@@ -58,6 +110,7 @@
   (define doc-text (Doc-text doc))
   (define doc-trace (Doc-trace doc))
 
+  (invalidate-resyntax-results! doc)
   (send doc-text erase)
   (send doc-trace reset)
   (send doc-text insert new-text 0))
@@ -72,6 +125,7 @@
   (define old-len (- end-pos st-pos))
   (define new-len (string-length text))
 
+  (invalidate-resyntax-results! doc)
   ;; try reuse old information as the check-syntax can fail
   ;; and return the old build-trace% object
   (cond [(> new-len old-len) (send doc-trace expand end-pos (+ st-pos new-len))]
@@ -121,18 +175,12 @@
   (-> Doc? boolean?)
   (equal? (Doc-version doc) (Doc-trace-version doc)))
 
-(define/contract (doc-walk-text trace text)
-  (-> (is-a?/c build-trace%) string? void?)
-  (send trace walk-text text))
-
 (define/contract (doc-expand! doc)
   (-> Doc? boolean?)
   (define result (doc-expand (Doc-uri doc) (Doc-text doc)))
   (define new-trace (CSResult-trace result))
   (cond [(CSResult-succeed? result)
-         (define text (CSResult-text result))
          (doc-update-trace! doc new-trace (Doc-version doc))
-         (doc-walk-text new-trace text)
          #t]
         [else #f]))
 
@@ -163,12 +211,43 @@
 
 (define/contract (doc-diagnostics doc)
   (-> Doc? (listof Diagnostic?))
-  (set->list (send (Doc-trace doc) get-warn-diags)))
+  (append (set->list (send (Doc-trace doc) get-warn-diags))
+          (for/list ([res (in-list (doc-get-resyntax-results doc))])
+            (resyntax-result->diag doc res))))
 
 (define/contract (doc-copy-text-buffer doc)
   (-> Doc? (is-a?/c lsp-editor%))
   (send (Doc-text doc) copy))
 
+(define (interval-map-iterate-least/end>?/fallback intervals end)
+  (let loop ([iter (interval-map-iterate-first intervals)])
+    (cond
+      [(not iter) #f]
+      [else
+       (match-define (cons _ interval-end)
+         (interval-map-iterate-key intervals iter))
+       (if (> interval-end end)
+           iter
+           (loop (interval-map-iterate-next intervals iter)))])))
+
+(define maybe-interval-map-iterate-least/end>?
+  (dynamic-require 'data/interval-map
+                   'interval-map-iterate-least/end>?
+                   (lambda () interval-map-iterate-least/end>?/fallback)))
+
+(define (interval-map-overlap-values intervals start end)
+  (let loop ([iter (maybe-interval-map-iterate-least/end>? intervals start)]
+             [values (list)])
+    (cond
+      [(not iter) (reverse values)]
+      [else
+       (match-define (cons interval-start _)
+         (interval-map-iterate-key intervals iter))
+       (if (>= interval-start end)
+           (reverse values)
+           (loop (interval-map-iterate-next intervals iter)
+                 (cons (interval-map-iterate-value intervals iter) values)))])))
+
 ;; TODO: Use lexer/token info here instead of scanning raw characters.
 (define/contract (doc-find-containing-paren doc pos)
   (-> Doc? exact-nonnegative-integer? (or/c exact-nonnegative-integer? #f))
@@ -459,11 +538,23 @@
 (define/contract (doc-code-action doc range)
   (-> Doc? Range? (listof CodeAction?))
   (define doc-trace (Doc-trace doc))
-  (define act
-    (interval-map-ref (send doc-trace get-quickfixs)
-                      (doc-pos->abs-pos doc (Range-start range))
-                      #f))
-  (if act (list act) (list)))
+  (define req-start (doc-pos->abs-pos doc (Range-start range)))
+  (define req-end (doc-pos->abs-pos doc (Range-end range)))
+  (define trace-actions
+    (interval-map-overlap-values (send doc-trace get-quickfixs)
+                                 req-start
+                                 req-end))
+
+  (define resyntax-actions
+    (for/list ([res (in-list (doc-get-resyntax-results doc))]
+               #:when (char-range-intersect?
+                        req-start
+                        req-end
+                        (Resyntax-Result-start res)
+                        (Resyntax-Result-end res)))
+      (resyntax-result->code-action doc res)))
+
+  (append trace-actions resyntax-actions))
 
 (define/contract (doc-signature-help doc pos)
   (-> Doc? Pos? (or/c SignatureHelp? #f))
@@ -671,7 +762,13 @@
          doc-update-trace!
          doc-trace-latest?
          doc-expand!
-         doc-walk-text
+         doc-resyntax
+         doc-resyntax!
+         doc-resyntax-available?
+         doc-get-resyntax-results
+         doc-update-resyntax-result!
+         resyntax-result->diag
+         resyntax-result->code-action
          doc-hover
          doc-code-action
          doc-signature-help

doclib/editor.rkt

@@ -17,7 +17,7 @@
 
     ;; insert str at start
     (define/public (insert str start)
-      (with-handlers ([exn?
+      (with-handlers ([exn:fail?
                        (λ _
                          (reload!)
                          ;; only retry once
@@ -26,7 +26,7 @@
 
     ;; replace text at (range start end) with str
     (define/public (replace str start end)
-      (with-handlers ([exn?
+      (with-handlers ([exn:fail?
                        (λ _
                          (reload!)
                          ;; only retry once

doclib/service/resyntax.rkt doclib/external/resyntax.rktdoclib/service/resyntax.rkt renamed to doclib/external/resyntax.rkt

@@ -1,15 +1,16 @@
 #lang racket/base
 
-(provide resyntax)
+(provide run-resyntax
+         resyntax-available?)
 
-(require racket/set
-         data/interval-map
-         "../../common/interfaces.rkt"
-         "../../common/path-util.rkt"
-         "dynamic-import.rkt")
+(require "../../common/dynamic-import.rkt"
+         "../../common/interfaces.rkt")
 
 (define has-resyntax? #t)
 
+(define (resyntax-available?)
+  has-resyntax?)
+
 (define (disable-resyntax!)
   (set! has-resyntax? #f))
 
@@ -37,12 +38,12 @@
                    resyntax-analyze)
                  disable-resyntax!)
 
+(define (run-resyntax text _src)
+  (if has-resyntax?
+      (run-resyntax-impl text)
+      (list)))
 
-(define (resyntax text doc-text src warn-diags quickfixs)
-  (when has-resyntax?
-    (resyntax-impl text doc-text src warn-diags quickfixs)))
-
-(define (resyntax-impl text doc-text src warn-diags quickfixs)
+(define (run-resyntax-impl text)
   (define text-source (string-source text))
   (define all-lines (range-set (unbounded-range #:comparator natural<=>)))
   (define result-set
@@ -51,34 +52,11 @@
       #:suite default-recommendations
       #:lines all-lines))
 
-  (define (add result)
+  (for/list ([result (in-list (refactoring-result-set-results result-set))])
     (define sr (refactoring-result-string-replacement result))
     (define char-start (string-replacement-start sr))
     (define char-end (string-replacement-original-end sr))
     (define message (refactoring-result-message result))
-    (define range (Range #:start (abs-pos->Pos doc-text char-start)
-                         #:end (abs-pos->Pos doc-text char-end)))
     (define new-text (string-replacement-render sr (source->string text-source)))
-
     (define rule-name (refactoring-result-rule-name result))
-    (define diag
-      (Diagnostic #:range range
-                  #:severity DiagnosticSeverity-Information
-                  #:source "Resyntax"
-                  #:message (format "[~a] ~a" rule-name message)))
-    (define code-action
-      (CodeAction
-        #:title (format "Apply rule [~a]" rule-name)
-        #:kind "quickfix"
-        #:diagnostics (list diag)
-        #:isPreferred #f
-        #:edit (WorkspaceEdit
-                 #:changes
-                 (hasheq (string->symbol (path->uri src))
-                         (list (TextEdit #:range range
-                                         #:newText new-text))))))
-    (set-add! warn-diags diag)
-    (interval-map-set! quickfixs char-start char-end code-action))
-
-  (for-each add (refactoring-result-set-results result-set)))
-
+    (Resyntax-Result char-start char-end message rule-name new-text)))