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

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))))

parse/private/parse.rkt

@@ -449,7 +449,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])
@@ -597,7 +599,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))]
@@ -790,7 +794,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])

parse/private/residual.rkt

@@ -315,10 +315,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)))))