Use module-lexer to parse comments

default-recommendations/comment-preservation-test.rkt

@@ -0,0 +1,104 @@
+#lang resyntax/test
+
+
+require: resyntax/default-recommendations let-replacement
+
+
+header:
+- #lang racket/base
+
+
+test: "expression comments are preserved between let bindings"
+------------------------------
+(define (foo)
+  (let ([x 1]
+        #;(debug-binding [z 0])
+        [y 2])
+    (+ x y)))
+==============================
+(define (foo)
+  (define x 1)
+  #;(debug-binding [z 0])
+  (define y 2)
+  (+ x y))
+------------------------------
+
+
+test: "expression comments with atoms are preserved between let bindings"
+------------------------------
+(define (foo)
+  (let ([x 1]
+        #;unused-binding
+        [y 2])
+    (+ x y)))
+==============================
+(define (foo)
+  (define x 1)
+  #;unused-binding
+  (define y 2)
+  (+ x y))
+------------------------------
+
+
+test: "block comments are preserved between let bindings"
+------------------------------
+(define (foo)
+  (let ([x 1]
+        #| The second
+           binding |#
+        [y 2])
+    (+ x y)))
+==============================
+(define (foo)
+  (define x 1)
+  #| The second
+           binding |#
+  (define y 2)
+  (+ x y))
+------------------------------
+
+
+test: "expression comments with nested sexps are preserved"
+------------------------------
+(define (foo)
+  (let ([x 1]
+        #;(commented-binding
+           [y 3]
+           [z 4])
+        [a 2])
+    (+ x a)))
+==============================
+(define (foo)
+  (define x 1)
+  #;(commented-binding [y 3] [z 4])
+  (define a 2)
+  (+ x a))
+------------------------------
+
+
+test: "expression comments in let body are preserved"
+------------------------------
+(define (foo)
+  (let ([x 1])
+    #;(debug-stmt)
+    (+ x 1)))
+==============================
+(define (foo)
+  (define x 1)
+  #;(debug-stmt)
+  (+ x 1))
+------------------------------
+
+
+test: "block comments in let body are preserved"
+------------------------------
+(define (foo)
+  (let ([x 1])
+    #| computation |#
+    (+ x 1)))
+==============================
+(define (foo)
+  (define x 1)
+  #| computation |#
+  (+ x 1))
+------------------------------

main.rkt

@@ -54,7 +54,6 @@
          resyntax/base
          resyntax/default-recommendations
          resyntax/private/analysis
-         resyntax/private/comment-reader
          resyntax/private/git
          resyntax/private/limiting
          resyntax/private/line-replacement
@@ -170,7 +169,7 @@
                                 #:suite [suite default-recommendations]
                                 #:lines [lines (range-set (unbounded-range #:comparator natural<=>))]
                                 #:timeout-ms [timeout-ms 10000])
-  (define comments (with-input-from-source source read-comment-locations))
+  (define comments (source-comment-locations source))
   (define source-lang (source-read-language source))
   (guard source-lang #:else
     (log-resyntax-warning "skipping ~a because its #lang could not be determined"
@@ -235,7 +234,7 @@
 (define/guard (reysntax-analyze-for-properties-only source
                                                     #:suite [suite default-recommendations]
                                                     #:timeout-ms [timeout-ms 10000])
-  (define comments (with-input-from-source source read-comment-locations))
+  (define comments (source-comment-locations source))
   (define full-source (source->string source))
   (guard (string-prefix? full-source "#lang racket") #:else
     (log-resyntax-warning "skipping ~a because it does not start with #lang racket"

private/source.rkt

@@ -18,6 +18,7 @@
   [source-expand (-> source? syntax?)]
   [source-can-expand? (-> source? boolean?)]
   [source-text-of (-> source? syntax? immutable-string?)]
+  [source-comment-locations (-> source? immutable-range-set?)]
   [file-source? (-> any/c boolean?)]
   [file-source (-> path-string? file-source?)]
   [file-source-path (-> file-source? path?)]
@@ -38,7 +39,13 @@
          rebellion/base/immutable-string
          resyntax/private/syntax-neighbors
          syntax/modread
-         syntax/parse)
+         rebellion/base/comparator
+         rebellion/base/range
+         rebellion/collection/range-set
+         rebellion/collection/vector/builder
+         rebellion/streaming/transducer
+         syntax-color/lexer-contract
+         syntax-color/module-lexer)
 
 
 (module+ test
@@ -179,3 +186,45 @@
   (define start (sub1 (syntax-position stx)))
   (define end (+ start (syntax-span stx)))
   (string->immutable-string (substring (source->string code) start end)))
+
+
+(define (source-comment-locations src)
+  (transduce (source-tokens src)
+             (filtering lexical-token-comment?)
+             (mapping lexical-token-location)
+             #:into (into-range-set natural<=>)))
+
+
+(struct lexical-token (text start end type delimiter-kind attributes) #:transparent)
+
+
+(define (source-tokens src)
+  (with-input-from-source src
+    (λ ()
+      (define tokens (make-vector-builder))
+      (let loop ([offset 0] [mode #false])
+        (define-values (text raw-attributes delimiter-kind start end _ new-mode)
+          (module-lexer* (current-input-port) offset mode))
+        (unless (eof-object? text)
+          (define type
+            (if (symbol? raw-attributes)
+                raw-attributes
+                (hash-ref raw-attributes 'type)))
+          (define attributes
+            (if (symbol? raw-attributes)
+                (hasheq)
+                (hash-remove raw-attributes 'type)))
+          (vector-builder-add tokens (lexical-token text (sub1 start) (sub1 end) type delimiter-kind attributes))
+          (loop (sub1 end) (if (dont-stop? new-mode) (dont-stop-val new-mode) new-mode))))
+      (build-vector tokens))))
+
+
+(define (lexical-token-comment? token)
+  (define type (lexical-token-type token))
+  (or (equal? type 'comment)
+      (equal? type 'sexp-comment)
+      (hash-ref (lexical-token-attributes token) 'comment? #false)))
+
+
+(define (lexical-token-location token)
+  (closed-open-range (lexical-token-start token) (lexical-token-end token) #:comparator natural<=>))

test/private/rackunit.rkt

@@ -128,7 +128,7 @@
 
 (define current-line-mask (make-parameter (range-set (unbounded-range #:comparator natural<=>))))
 
-(define current-analyzer-timeout-millis (make-parameter 100))
+(define current-analyzer-timeout-millis (make-parameter 1000))
 
 
 (define (range-bound-add bound amount)