syntax/parse: add unwindable state: syntax-parse-state-{ref,set!,...}

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

@@ -23,6 +23,7 @@ messages embedded in the macro's syntax patterns.
 @include-section["parse/define.scrbl"]
 @include-section["parse/litconv.scrbl"]
 @include-section["parse/lib.scrbl"]
+@include-section["parse/state.scrbl"]
 
 @;{Description of how error reporting works}
 @;{and designing for good errors}

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

@@ -0,0 +1,53 @@
+#lang scribble/doc
+@(require scribble/manual
+          scribble/struct
+          scribble/decode
+          scribble/eval
+          "parse-common.rkt")
+
+@(define the-eval (make-sp-eval))
+
+@title[#:tag "state"]{Unwindable State}
+
+@declare-exporting[syntax/parse]
+
+@deftogether[[
+@defproc[(syntax-parse-state-ref [key any/c]
+                                 [default default/c (lambda () (error ....))])
+         any/c]
+@defproc[(syntax-parse-state-set! [key any/c] [value any/c]) void?]
+@defproc[(syntax-parse-state-update! [key any/c]
+                                     [update (-> any/c any/c)]
+                                     [default default/c (lambda () (error ....))])
+         void?]
+@defproc[(syntax-parse-state-cons! [key any/c]
+                                   [value any/c]
+                                   [default default/c null])
+         void?]
+]]{
+
+Get or update the current @racket[syntax-parse] state. Updates to the
+state are unwound when @racket[syntax-parse] backtracks. Keys are
+compared using @racket[eq?].
+
+The state can be updated only within @racket[~do] patterns (or
+@racket[#:do] blocks). In addition, @racket[syntax-parse]
+automatically adds identifiers that match literals (from
+@racket[~literal] patterns and literals declared with
+@racket[#:literals], but not from @racket[~datum] or
+@racket[#:datum-literals]) under the key @racket['literals].
+
+@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-parse #'(cond [A => B] [else C])
+  [(_ c:cond-clause ...) (syntax-parse-state-ref 'literals null)])
+]
+
+@history[#:added "6.11.0.4"]
+}
+
+@(close-eval the-eval)

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

@@ -535,6 +535,31 @@
       (check-equal? (reverse (lits)) '(a c))))
   )
 
+;; state unwinding
+
+(let ()
+  (define total
+    (case-lambda [() (syntax-parse-state-ref 'total 0)]
+                 [(n) (syntax-parse-state-set! 'total n)]))
+  (define-syntax-class nat/add
+    (pattern n:nat #:do [(total (+ (total) (syntax-e #'n)))]))
+  (test-case "state 1"
+    (syntax-parse #'(1 2 3)
+      [(n:nat/add ...) (check-equal? (total) (+ 1 2 3))]))
+  (test-case "state 2"
+    (syntax-parse #'(1 2 3 reset 5 6)
+      [((~or (~seq) (~seq _ ... (~not _:nat))) n:nat/add ...)
+       (check-equal? (total) (+ 5 6))])))
+
+(test-case "state and literals"
+  (check-equal?
+   (map syntax-e
+        (syntax-parse #'(define lambda)
+          #:literals (define lambda)
+          [(define define) (syntax-parse-state-ref 'literals null)]
+          [(_      lambda) (syntax-parse-state-ref 'literals null)]))
+   '(lambda)))
+
 ;; == Lib tests
 
 ;; test string, bytes act as stxclasses

racket/collects/syntax/parse/pre.rkt

@@ -1,10 +1,46 @@
 #lang racket/base
 (require "private/sc.rkt"
          "private/litconv.rkt"
-         "private/lib.rkt")
+         "private/lib.rkt"
+         "private/residual.rkt")
 (provide (except-out (all-from-out "private/sc.rkt")
                      define-integrable-syntax-class
                      syntax-parser/template
                      parser/rhs)
          (all-from-out "private/litconv.rkt")
-         (all-from-out "private/lib.rkt"))
+         (all-from-out "private/lib.rkt")
+         syntax-parse-state-ref
+         syntax-parse-state-set!
+         syntax-parse-state-update!
+         syntax-parse-state-cons!)
+
+(define not-given (gensym))
+
+(define (state-ref who key default)
+  (define state (current-state))
+  (if (eq? default not-given)
+      (if (hash-has-key? state key)
+          (hash-ref state key)
+          (error who "no value found for key\n  key: ~e" key))
+      (hash-ref state key default)))
+
+(define (syntax-parse-state-ref key [default not-given])
+  (state-ref 'syntax-parse-state-ref key default))
+
+(define (check-update who)
+  (unless (current-state-writable?)
+    (error who "cannot update syntax-parse state outside of ~~do/#:do block")))
+
+(define (syntax-parse-state-set! key value)
+  (check-update 'syntax-parse-state-set!)
+  (current-state (hash-set (current-state) key value)))
+
+(define (syntax-parse-state-update! key update [default not-given])
+  (check-update 'syntax-parse-state-update!)
+  (define old (state-ref 'syntax-parse-state-update! key default))
+  (current-state (hash-set (current-state) key (update old))))
+
+(define (syntax-parse-state-cons! key value [default null])
+  (check-update 'syntax-parse-state-cons!)
+  (define old (hash-ref (current-state) key default))
+  (current-state (hash-set (current-state) key (cons value old))))

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

@@ -443,7 +443,9 @@ Conventions:
                    [cx x]
                    [fh0 (syntax-patterns-fail ctx0)])
               def ...
-              (parameterize ((current-syntax-context (cadr ctx0)))
+              (parameterize ((current-syntax-context (cadr ctx0))
+                             (current-state '#hasheq())
+                             (current-state-writable? #f))
                 (with ([fail-handler fh0]
                        [cut-prompt fh0]
                        [undo-stack null])
@@ -591,7 +593,9 @@ Conventions:
        [#s(pat:literal literal input-phase lit-phase)
         #`(if (and (identifier? x)
                    (free-identifier=? x (quote-syntax literal) input-phase lit-phase))
-              k
+              (with ([undo-stack (cons (current-state) undo-stack)])
+                (state-cons! 'literals x)
+                k)
               (fail (failure* pr (es-add-literal (quote-syntax literal) es))))]
        [#s(pat:action action subpattern)
         #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))]
@@ -784,7 +788,12 @@ Conventions:
                  [pr* (ps-add-stx pr y)])
             (parse:S y cy pattern pr* es k))]
        [#s(action:do (stmt ...))
-        #'(let () (no-shadow stmt) ... (#%expression k))]
+        #'(parameterize ((current-state-writable? #t))
+            (let ([init-state (current-state)])
+              (no-shadow stmt) ...
+              (parameterize ((current-state-writable? #f))
+                (with ([undo-stack (maybe-add-state-undo init-state (current-state) undo-stack)])
+                  (#%expression k)))))]
        [#s(action:undo (stmt ...))
         #'(with ([undo-stack (cons (lambda () stmt ... (void)) undo-stack)]
                  [cut-prompt illegal-cut-error])

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

@@ -306,10 +306,35 @@
 (define (illegal-cut-error . _)
   (error 'syntax-parse "illegal use of cut"))
 
-(provide unwind-to)
+;; ----
+
+(provide unwind-to
+         maybe-add-state-undo
+         current-state
+         current-state-writable?
+         state-cons!)
 
 (define (unwind-to undos base)
-  ;; PRE: undos = (list* proc ... base)
+  ;; PRE: undos = (list* proc/hash ... base)
   (unless (eq? undos base)
-    ((car undos))
+    (let ([top-undo (car undos)])
+      (cond [(procedure? top-undo) (top-undo)]
+            [(hash? top-undo) (current-state top-undo)]))
     (unwind-to (cdr undos) base)))
+
+(define (maybe-add-state-undo init-state new-state undos)
+  (if (eq? init-state new-state)
+      undos
+      (cons init-state undos)))
+
+;; To make adding undos to rewind current-state simpler, only allow updates
+;; in a few contexts:
+;; - literals (handled automatically)
+;; - in ~do/#:do blocks (sets current-state-writable? = #t)
+
+(define current-state (make-parameter (hasheq)))
+(define current-state-writable? (make-parameter #f))
+
+(define (state-cons! key value)
+  (define state (current-state))
+  (current-state (hash-set state key (cons value (hash-ref state key null)))))