use new protocol to report expression-comment regions

syntax-color-doc/syntax-color/syntax-color.scrbl

@@ -36,10 +36,17 @@ Parenthesis matching code built on top of @racket[token-tree%].
 @defmodule[syntax-color/lexer-contract]
 
 @defthing[lexer/c contract?]{
-  Checks to be sure a lexing function is well-behaved. For more
+  Checks to be sure a lexing function is well-behaved, constrained to
+  functions where the second return value is a symbol. For more
   details, see @xmethod[color:text<%> start-colorer].
 }
 
+@defthing[lexer*/c contract?]{
+  Checks to be sure a lexing function is well-behaved. For more
+  details, see @xmethod[color:text<%> start-colorer].
+
+ @history[#:added "1.2"]}
+
 @defstruct*[dont-stop ([val any/c])]{
   A structure type used to indicate to the lexer that it should not
   allow itself to be interrupted. For more details,
@@ -79,6 +86,23 @@ The @racket[racket-lexer] function returns 5 values:
 
 }
 
+@defproc[(racket-lexer* [in input-port?]
+                        [offset exact-nonnegative-integer?]
+                        [mode any/c])
+         (values (or/c string? eof-object?) 
+                 (or/c symbol?
+                       (and/c (hash/c symbol? any/c) immutable?))
+                 (or/c symbol? #f) 
+                 (or/c number? #f) 
+                 (or/c number? #f)
+                 exact-nonnegative-integer?
+                 any/c)]{
+
+Like @racket[racket-lexer], but uses the extended lexer protocol to
+track and report regions that are commented out with @litchar{#;}.
+
+@history[#:added "1.2"]}
+
 @defproc[(racket-lexer/status [in input-port?]) 
          (values (or/c string? eof-object?) 
                  symbol?
@@ -93,6 +117,24 @@ datum, an opening parenthesis (or similar starting token to group
 other tokens), a closing parenthesis (or similar), or a prefix (such
 as whitespace) on a datum.}
 
+@defproc[(racket-lexer*/status [in input-port?]
+                               [offset exact-nonnegative-integer?]
+                               [mode any/c]) 
+         (values (or/c string? eof-object?) 
+                 (or/c symbol?
+                       (and/c (hash/c symbol? any/c) immutable?))
+                 (or/c symbol? #f) 
+                 (or/c number? #f) 
+                 (or/c number? #f)
+                 exact-nonnegative-integer?
+                 any/c
+                 (or/c 'datum 'open 'close 'continue))]{
+
+Like @racket[racket-lexer/status], but with comment tracking like
+@racket[racket-lexer*].
+
+@history[#:added "1.2"]}
+
 @defproc[(racket-nobar-lexer/status [in input-port?]) 
          (values (or/c string? eof-object?) 
                  symbol?
@@ -105,6 +147,23 @@ Like @racket[racket-lexer/status], except it treats
 @litchar{|} as a delimiter instead of quoting syntax for a symbol.
 This function is used by @racket[scribble-lexer].}
 
+@defproc[(racket-nobar-lexer*/status [in input-port?]
+                                     [offset exact-nonnegative-integer?]
+                                     [mode any/c]) 
+         (values (or/c string? eof-object?) 
+                 (or/c symbol?
+                       (and/c (hash/c symbol? any/c) immutable?))
+                 (or/c symbol? #f) 
+                 (or/c number? #f) 
+                 (or/c number? #f)
+                 exact-nonnegative-integer?
+                 any/c
+                 (or/c 'datum 'open 'close 'continue))]{
+
+Like @racket[racket-nobar-lexer/status], but with comment tracking like
+@racket[racket-lexer*].
+
+@history[#:added "1.2"]}
 
 @section{Default Lexer}
 @defmodule[syntax-color/default-lexer]
@@ -188,7 +247,9 @@ Like @racket[racket-lexer], but with several differences:
 
  @item{When @racket[mode] is a lexer procedure, the lexer is applied
        to @racket[in]. The lexer's results are returned, plus the
-       lexer again as the mode.}
+       lexer again as the mode; if the lexer produces a hash-table
+       attribute result, however, the @racket['type] value is
+       extracted and returned in place of the hash table.}
 
  @item{When @racket[mode] is a pair, then the lexer procedure in the
        @racket[car] is applied to @racket[in], @racket[offset], and the mode in the
@@ -197,46 +258,76 @@ Like @racket[racket-lexer], but with several differences:
 
 ]}
 
+@defproc[(module-lexer* [in input-port?]
+                        [offset exact-nonnegative-integer?]
+                        [mode (or/c #f
+                                    (-> input-port? any)
+                                    (cons/c (-> input-port? any/c any) any/c))])
+         (values (or/c string? eof-object?) 
+                 (or/c symbol?
+                       (and/c (hash/c symbol? any/c) immutable?))
+                 (or/c symbol? #f) 
+                 (or/c number? #f) 
+                 (or/c number? #f)
+                 exact-nonnegative-integer?
+                 (or/c #f 
+                       (-> input-port? any)
+                       (cons/c (-> input-port? any/c any) any/c)))]{
+
+Like @racket[module-lexer], except that the attribute result
+propagated from a language-specific lexer can be a hash table.
+
+@history[#:added "1.2"]}
+
 @section{Scribble Lexer}
 
 @defmodule[syntax-color/scribble-lexer]
 
 @defproc[(scribble-lexer [in input-port?]
                          [offset exact-nonnegative-integer?]
                          [mode any/c])
-         (values (or/c string? eof-object?) 
-                 symbol?
+         (values (or/c string? eof-object?)
+                 (or/c symbol?
+                       (and/c (hash/c symbol? any/c) immutable?))
                  (or/c symbol? #f) 
                  (or/c number? #f) 
                  (or/c number? #f)
                  exact-nonnegative-integer?
                  any/c)]{
 
-Like @racket[racket-lexer], but for Racket extended with Scribble's
+Like @racket[racket-lexer*], but for Racket extended with Scribble's
 @"@" notation (see @secref[#:doc '(lib
-"scribblings/scribble/scribble.scrbl") "reader"]).}
+"scribblings/scribble/scribble.scrbl") "reader"]).
+
+@history[#:changed "1.2" @elem{Changed to be like @racket[racket-lexer*]
+                               instead of @racket[racket-lexer].}]}
 
 @defproc[(scribble-inside-lexer [in input-port?]
                                 [offset exact-nonnegative-integer?]
                                 [mode any/c])
          (values (or/c string? eof-object?) 
-                 symbol?
+                 (or/c symbol?
+                       (and/c (hash/c symbol? any/c) immutable?))
                  (or/c symbol? #f) 
                  (or/c number? #f) 
                  (or/c number? #f)
                  exact-nonnegative-integer?
                  any/c)]{
 
 Like @racket[scribble-lexer], but starting in ``text'' mode instead of
-Racket mode.}
+Racket mode.
+
+@history[#:changed "1.2" @elem{Changed to be like @racket[racket-lexer*]
+                               instead of @racket[racket-lexer].}]}
 
 @defproc[(make-scribble-lexer [#:command-char at (and/c char? (not/c (or/c #\] #\[))) #\@])
          lexer/c]{
 
 Produces a lexer like @racket[scribble-lexer], but using
 @racket[at] in place of @litchar["@"].
 
-@history[#:added "1.1"]}
+@history[#:added "1.1"
+         #:changed "1.2" @elem{Changed like @racket[scribble-lexer].}]}
 
 
 @defproc[(make-scribble-inside-lexer [#:command-char at (and/c char? (not/c (or/c #\] #\[))) #\@])
@@ -245,7 +336,8 @@ Produces a lexer like @racket[scribble-lexer], but using
 Produces a lexer function like @racket[scribble-inside-lexer], but using
 @racket[at] in place of @litchar["@"].
 
-@history[#:added "1.1"]}
+@history[#:added "1.1"
+         #:changed "1.2" @elem{Changed like @racket[scribble-lexer].}]}
 
 @; ----------------------------------------------------------------------
 

syntax-color-lib/info.rkt

@@ -11,4 +11,4 @@
 
 (define pkg-authors '(mflatt))
 
-(define version "1.1")
+(define version "1.2")

syntax-color-lib/syntax-color/lexer-contract.rkt

@@ -1,7 +1,9 @@
 #lang racket/base
 (require racket/contract/base
          racket/contract/option)
-(provide lexer/c (struct-out dont-stop))
+(provide lexer/c
+         lexer*/c
+         (struct-out dont-stop))
 
 (struct dont-stop (val) #:transparent)
 
@@ -25,6 +27,20 @@
                       [new-mode any/c])))
    #:tester (λ (lexer) (try-some-random-streams lexer))))
 
+(define lexer*/c
+  (option/c
+   (->i ([in (and/c input-port? port-counts-lines?)]
+         [offset exact-nonnegative-integer?]
+         [mode (not/c dont-stop?)])
+        (values [txt any/c]
+                [type (or/c symbol? (and/c (hash/c symbol? any/c) immutable?))]
+                [paren (or/c symbol? #f)]
+                [start (or/c exact-positive-integer? #f)]
+                [end (start type) (end/c start type)]
+                [backup exact-nonnegative-integer?]
+                [new-mode any/c]))
+   #:tester (λ (lexer) (try-some-random-streams lexer))))
+
 (define (try-some-random-streams lexer)
   (define 3ary-lexer
     (cond

syntax-color-lib/syntax-color/module-lexer.rkt

@@ -5,7 +5,8 @@
          racket/contract
          racket/contract/option)
 (provide 
- (contract-out [module-lexer lexer/c]))
+ (contract-out [module-lexer lexer/c]
+               [module-lexer* lexer*/c]))
 
 #|
 
@@ -27,7 +28,7 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
 |#
 
 
-(define (module-lexer in offset mode)
+(define (do-module-lexer* in offset mode filter-lexer)
   (cond
     [(or (not mode) (eq? mode 'before-lang-line))
      (define lexer-port (peeking-input-port in #:init-position (+ 1 (file-position in))))
@@ -89,7 +90,7 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
              (read-byte-or-special in))
 
            (define the-lexer 
-             (let ([raw-lexer (or (get-info 'color-lexer #f) racket-lexer)])
+             (let ([raw-lexer (filter-lexer (or (get-info 'color-lexer #f) racket-lexer*))])
                (if (trusted-lexer? raw-lexer)
                    (waive-option raw-lexer)
                    (exercise-option raw-lexer))))
@@ -136,6 +137,28 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
                    (mode in)])
        (values lexeme type data new-token-start new-token-end 0 mode))]))
 
+(define (module-lexer* in offset mode)
+  (do-module-lexer* in offset mode (lambda (lexer) lexer)))
+
+(define (module-lexer in offset mode)
+  (define (attribs->symbol type)
+    (if (symbol? type)
+        type
+        (hash-ref type 'type 'unknown)))
+  (define-values (lexeme type data start end backup new-mode)
+    (do-module-lexer* in offset mode (lambda (lexer)
+                                       (cond
+                                         [(eq? lexer racket-lexer*) racket-lexer]
+                                         [(not (procedure-arity-includes? lexer 3)) lexer]
+                                         [else
+                                          (procedure-rename
+                                           (lambda (in offset mode)
+                                             (define-values (lexeme type data start end backup new-mode)
+                                               (lexer in offset mode))
+                                             (values lexeme (attribs->symbol type) data start end backup new-mode))
+                                           (object-name lexer))]))))
+  (values lexeme (attribs->symbol type) data start end backup new-mode))
+
 (define (set-port-next-location-from src dest)
   (define-values (line col pos) (port-next-location src))
   (set-port-next-location! dest line col pos))
@@ -144,7 +167,6 @@ to delegate to the scheme-lexer (in the 'no-lang-line mode).
 (define (trusted-lexer? the-lexer)
   (member (object-name the-lexer)
           '(racket-lexer 
-            racket-lexer/status 
-            racket-nobar-lexer/status
+            racket-lexer*
             scribble-inside-lexer
             scribble-lexer)))

syntax-color-lib/syntax-color/racket-lexer.rkt

@@ -7,9 +7,12 @@
 
   (provide 
    (contract-out
-    [racket-lexer lexer/c])
+    [racket-lexer lexer/c]
+    [racket-lexer* lexer*/c])
    racket-lexer/status
-   racket-nobar-lexer/status)
+   racket-nobar-lexer/status
+   racket-lexer*/status
+   racket-nobar-lexer*/status)
 
   (define-lex-abbrevs
 
@@ -411,7 +414,46 @@
 
   (define racket-lexer/status (lexer/status identifier keyword bad-id))
   (define racket-nobar-lexer/status (lexer/status nobar-identifier nobar-keyword nobar-bad-id))
-
+
+  (struct comment-mode (prev balance) #:prefab)
+  (define ((make-comment-tracking racket-lexer/status) in offset mode)
+    (define-values (lexeme type paren start end status)
+      (racket-lexer/status in))
+    (define attribs (if (and (comment-mode? mode)
+                             (not (eq? type 'eof)))
+                        (hash 'type type 'comment? #t)
+                        type))
+    (values lexeme attribs paren start end 0
+            (cond
+              [(eq? type 'sexp-comment)
+               (comment-mode mode 0)]
+              [(comment-mode? mode)
+               (case paren
+                 [(|(| |[| |{|)
+                  (struct-copy comment-mode mode
+                               [balance (add1 (comment-mode-balance mode))])]
+                 [(|)| |]| |}|)
+                  (define balance (sub1 (comment-mode-balance mode)))
+                  (if (zero? balance)
+                      (comment-mode-prev mode)
+                      (struct-copy comment-mode mode
+                                   [balance balance]))]
+                 [else
+                  (case type
+                    [(white-space comment) mode]
+                    [else
+                     (if (zero? (comment-mode-balance mode))
+                         (comment-mode-prev mode)
+                         mode)])])])
+            status))
+
+  (define racket-lexer*/status (make-comment-tracking racket-lexer/status))
+  (define racket-nobar-lexer*/status (make-comment-tracking racket-nobar-lexer/status))
+
+  (define (racket-lexer* in offset mode)
+    (let-values ([(lexeme type paren start end backup mode adj) (racket-lexer*/status in offset mode)])
+      (values lexeme type paren start end backup mode)))
+
   (define (extend-error lexeme start end in)
     (define next (peek-char-or-special in))
     (if (or (char-whitespace? next)