syntax/parse: Add #:track-literals and syntax-parse-track-literals

pkgs/racket-doc/syntax/scribblings/parse/define.scrbl

@@ -20,6 +20,7 @@ Defines a macro named @racket[macro-id]; equivalent to the following:
 @racketblock[
 (define-syntax (macro-id stx)
   (syntax-parse stx
+    #:track-literals
     [((~var macro-id id) . pattern) pattern-directive ... (syntax template)]))
 ]
 
@@ -41,7 +42,9 @@ Defines a macro named @racket[macro-id]; equivalent to the following:
 @history[#:changed "6.12.0.3" @elem{Changed pattern head to @racket[(~var macro-id id)] from
                                     @racket[macro-id], allowing tilde-prefixed identifiers or
                                     identifiers containing colons to be used as @racket[macro-id]
-                                    without producing a syntax error.}]
+                                    without producing a syntax error.}
+         #:changed "6.90.0.29" @elem{Changed to always use the @racket[#:track-literals]
+                                     @racket[syntax-parse] option.}]
 }
 
 @defform[(define-syntax-parser macro-id parse-option ... clause ...+)]{

pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl

@@ -73,7 +73,15 @@ When used outside of the dynamic extent of a macro transformer (see
 @racket[syntax-transforming?]), matching fails.
 
 The attribute @var[value] contains the value the name is bound to.
-}
+
+If matching succeeds, @racket[static] additionally adds the matched identifier
+to the current @racket[syntax-parse] state under the key @racket['literals]
+using @racket[syntax-parse-state-cons!], in the same way as identifiers matched
+using @racket[#:literals] or @racket[~literal].
+
+@history[#:changed "6.90.0.29"
+         @elem{Changed to add matched identifiers to the @racket[syntax-parse]
+               state under the key @racket['literals].}]}
 
 @defstxclass[(expr/c [contract-expr syntax?]
                      [#:positive pos-blame

pkgs/racket-doc/syntax/scribblings/parse/parsing.scrbl

@@ -3,6 +3,7 @@
           scribble/struct
           scribble/decode
           scribble/eval
+          "../common.rkt"
           "parse-common.rkt"
           (for-label racket/syntax))
 
@@ -28,6 +29,7 @@ Two parsing forms are provided: @racket[syntax-parse] and
                         (code:line #:literals (literal ...))
                         (code:line #:datum-literals (datum-literal ...))
                         (code:line #:literal-sets (literal-set ...))
+                        #:track-literals
                         (code:line #:conventions (convention-id ...))
                         (code:line #:local-conventions (convention-rule ...))
                         (code:line #:disable-colon-notation)]
@@ -157,6 +159,24 @@ patterns are treated as literals; this option is useful primarily for
 macros that generate @racket[syntax-parse] expressions.
 }
 
+@specsubform[(code:line #:track-literals)]{
+
+If specified, each final @racket[body] expression is further constrained to
+produce a single value, which must be a @tech[#:doc refman]{syntax object}, and
+its @racket['disappeared-use] @tech[#:doc refman]{syntax property} is
+automatically extended to include literals matched as part of pattern-matching.
+Literals are automatically tracked from uses of @racket[#:literals],
+@racket[#:literal-sets], or @racket[~literal], but they can also be manually
+tracked using @racket[syntax-parse-state-cons!]. The property is added or
+extended in the same way as a property added by
+@racket[syntax-parse-track-literals].
+
+Due to the way the @racket[body] forms are wrapped, specifying this option means
+the final @racket[body] form will no longer be in tail position with respect to
+the enclosing @racket[syntax-parse] form.
+
+@history[#:added "6.90.0.29"]}
+
 @specsubform[(code:line #:conventions (conventions-id ...))]{
 
 Imports @tech{convention}s that give default syntax classes to pattern

pkgs/racket-doc/syntax/scribblings/parse/state.scrbl

@@ -3,6 +3,7 @@
           scribble/struct
           scribble/decode
           scribble/eval
+          "../common.rkt"
           "parse-common.rkt")
 
 @(define the-eval (make-sp-eval))
@@ -50,4 +51,45 @@ automatically adds identifiers that match literals (from
 @history[#:added "6.11.0.4"]
 }
 
+@defproc[(syntax-parse-track-literals [stx syntax?] [#:introduce? introduce? any/c #t]) syntax?]{
+
+Add a @racket['disappeared-use] @tech[#:doc refman]{syntax property} to
+@racket[stx] containing the information stored in the current
+@racket[syntax-parse] state under the key @racket['literals]. If
+@racket[stx] already has a @racket['disappeared-use] property, the
+added information is @racket[cons]ed onto the property’s current value.
+
+Due to the way @racket[syntax-parse] automatically adds identifiers that match
+literals to the state under the key @racket['literals], as described in the
+documentation for @racket[syntax-parse-state-ref],
+@racket[syntax-parse-track-literals] can be used to automatically add any
+identifiers used as literals to the @racket['disappeared-use] property.
+
+If @racket[syntax-parse-track-literals] is called within the dynamic
+extent of a @tech[#:doc refman]{syntax transformer} (see
+@racket[syntax-transforming?]), @racket[introduce?] is not @racket[#f], and the
+value in the current @racket[syntax-parse] state under the key
+@racket['literals] is a list, then @racket[syntax-local-introduce] is applied to
+any identifiers in the list before they are added to @racket[stx]’s
+@racket['disappeared-use] property.
+
+Most of the time, it is unnecessary to call this function directly. Instead, the
+@racket[#:track-literals] option should be provided to @racket[syntax-parse],
+which will automatically call @racket[syntax-parse-track-literals] on
+syntax-valued results.
+
+@examples[#:eval the-eval
+(define-syntax-class cond-clause
+  #:literals (=> else)
+  (pattern [test:expr => ~! answer:expr ...])
+  (pattern [else answer:expr ...])
+  (pattern [test:expr answer:expr ...]))
+(syntax-property
+ (syntax-parse #'(cond [A => B] [else C])
+   [(_ c:cond-clause ...) (syntax-parse-track-literals #'#f)])
+ 'disappeared-use)
+]
+
+@history[#:added "6.90.0.29"]}
+
 @(close-eval the-eval)

pkgs/racket-test/tests/stxparse/test.rkt

@@ -571,6 +571,27 @@
           [(_      lambda) (syntax-parse-state-ref 'literals null)]))
    '(lambda)))
 
+(test-case "track disappeared uses (implicit)"
+  (check-equal?
+   (map syntax-e
+        (syntax-property (syntax-parse #'(define lambda)
+                           #:literals (define lambda)
+                           #:track-literals
+                           [(define define) #'#f]
+                           [(_      lambda) #'#f])
+                         'disappeared-use))
+   '(lambda)))
+
+(test-case "track disappeared uses (explicit)"
+  (check-equal?
+   (map syntax-e
+        (syntax-property (syntax-parse #'(define lambda)
+                           #:literals (define lambda)
+                           [(define define) (syntax-parse-track-literals #'#f)]
+                           [(_      lambda) (syntax-parse-track-literals #'#f)])
+                         'disappeared-use))
+   '(lambda)))
+
 ;; == Lib tests
 
 ;; test string, bytes act as stxclasses

racket/collects/syntax/parse/pre.rkt

@@ -12,7 +12,8 @@
          syntax-parse-state-ref
          syntax-parse-state-set!
          syntax-parse-state-update!
-         syntax-parse-state-cons!)
+         syntax-parse-state-cons!
+         syntax-parse-track-literals)
 
 (define not-given (gensym))
 
@@ -44,3 +45,6 @@
   (check-update 'syntax-parse-state-cons!)
   (define old (hash-ref (current-state) key default))
   (current-state (hash-set (current-state) key (cons value old))))
+
+(define (syntax-parse-track-literals stx #:introduce? [introduce? #t])
+  (track-literals 'syntax-parse-track-literals stx #:introduce? introduce?))

racket/collects/syntax/parse/private/lib.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require "sc.rkt"
          "keywords.rkt"
+         (only-in "residual.rkt" state-cons!)
          (for-syntax syntax/parse/private/residual-ct)
          (for-syntax racket/base))
 
@@ -83,4 +84,5 @@
                          "not within the dynamic extent of a macro transformation"
            #:attr value (syntax-local-value #'x (lambda () notfound))
            #:fail-when (eq? (attribute value) notfound) #f
-           #:fail-unless (pred (attribute value)) #f))
+           #:fail-unless (pred (attribute value)) #f
+           #:do [(state-cons! 'literals #'x)]))

racket/collects/syntax/parse/private/parse.rkt

@@ -406,6 +406,9 @@ Conventions:
           (options-select-value chunks '#:context #:default #'x))
         (define colon-notation?
           (not (assq '#:disable-colon-notation chunks)))
+        (define track-literals?
+          (or (assq '#:track-literals chunks)
+              (eq? (syntax-e #'body-mode) 'one-template)))
         (define-values (decls0 defs)
           (get-decls+defs chunks #t #:context #'ctx))
         ;; for-clause : stx -> (values pattern stx (listof stx))
@@ -427,13 +430,16 @@ Conventions:
                            [_ (raise-syntax-error #f "expected exactly one template" #'ctx)]))
                         ((body-sequence)
                          (syntax-case rest ()
-                           [(e0 e ...) #'(let () e0 e ...)]
+                           [(e0 e ...)
+                            #'(let () e0 e ...)]
                            [_ (raise-syntax-error #f "expected non-empty clause body"
                                                   #'ctx clause)]))
                         (else
                          (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))])
                  (values pattern body-expr defs2)))]
             [_ (raise-syntax-error #f "expected clause" #'ctx clause)]))
+        (define (wrap-track-literals stx)
+          (if track-literals? (quasisyntax/loc stx (track-literals '#,who #,stx)) stx))
         (unless (stx-list? clauses-stx)
           (raise-syntax-error #f "expected sequence of clauses" #'ctx))
         (define-values (patterns body-exprs defs2s)
@@ -451,7 +457,8 @@ Conventions:
               (parameterize ((current-syntax-context (cadr ctx0))
                              (current-state '#hasheq())
                              (current-state-writable? #f))
-                (with ([fail-handler fh0]
+                #,(wrap-track-literals
+                 #`(with ([fail-handler fh0]
                           [cut-prompt fh0]
                           [undo-stack null])
                      #,(cond [(pair? patterns)
@@ -469,7 +476,7 @@ Conventions:
                                 #`(try alternative ...))
                               |#]
                              [else
-                           #`(fail (failure* pr es))]))))))))]))
+                              #`(fail (failure* pr es))])))))))))]))
 
 ;; ----
 

racket/collects/syntax/parse/private/rep.rkt

@@ -1610,6 +1610,7 @@
 ;; parse-directive-table
 (define parse-directive-table
   (list* (list '#:context check-expression)
+         (list '#:track-literals)
          common-parse-directive-table))
 
 ;; rhs-directive-table

racket/collects/syntax/parse/private/residual.rkt

@@ -253,7 +253,8 @@
          maybe-add-state-undo
          current-state
          current-state-writable?
-         state-cons!)
+         state-cons!
+         track-literals)
 
 (define (unwind-to undos base)
   ;; PRE: undos = (list* proc/hash ... base)
@@ -279,3 +280,21 @@
 (define (state-cons! key value)
   (define state (current-state))
   (current-state (hash-set state key (cons value (hash-ref state key null)))))
+
+(define (track-literals who v #:introduce? [introduce? #t])
+  (unless (syntax? v)
+    (raise-argument-error who "syntax?" v))
+  (let* ([literals (hash-ref (current-state) 'literals '())])
+    (if (null? literals)
+        v
+        (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals))
+                             (for/list ([literal (in-list literals)])
+                               (if (identifier? literal)
+                                   (syntax-local-introduce literal)
+                                   literal))
+                             literals)]
+              [old-val (syntax-property v 'disappeared-use)])
+          (syntax-property v 'disappeared-use
+                           (if old-val
+                               (cons literals* old-val)
+                               literals*))))))