syntax/parse: add ~undo, #:undo for unwinding effects

Note: this version doesn't work with ~commit or ~!, because
it stores both choice points and undo actions in the failure
continuation. Commit and cut should discard choice points but
preserve undo actions.

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

@@ -29,6 +29,7 @@
 (define-keyword ~fail)
 (define-keyword ~parse)
 (define-keyword ~do)
+(define-keyword ~undo)
 (define-keyword ...+)
 (define-keyword ~delimit-cut)
 (define-keyword ~commit)

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

@@ -771,6 +771,10 @@ Conventions:
             (parse:S y cy pattern pr* es k))]
        [#s(action:do (stmt ...))
         #'(let () (no-shadow stmt) ... (#%expression k))]
+       [#s(action:undo (stmt ...))
+        #'(try (with ([cut-prompt illegal-cut-error])
+                 (#%expression k))
+               (begin (#%expression stmt) ... (fail (failure* pr es))))]
        [#s(action:ord pattern group index)
         #'(let ([pr* (ps-add pr '#s(ord group index))])
             (parse:A x cx pattern pr* es k))]

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

@@ -73,6 +73,7 @@ A ActionPattern is one of
   (action:and (listof ActionPattern))
   (action:parse SinglePattern stx)
   (action:do (listof stx))
+  (action:undo (listof stx))
   (action:ord ActionPattern UninternedSymbol Nat)
   (action:post ActionPattern)
 
@@ -86,6 +87,7 @@ A SideClause is just an ActionPattern
 (define-struct action:and (patterns) #:prefab)
 (define-struct action:parse (pattern expr) #:prefab)
 (define-struct action:do (stmts) #:prefab)
+(define-struct action:undo (stmts) #:prefab)
 (define-struct action:ord (pattern group index) #:prefab)
 (define-struct action:post (pattern) #:prefab)
 
@@ -167,6 +169,7 @@ A RepConstraint is one of
       (action:and? x)
       (action:parse? x)
       (action:do? x)
+      (action:undo? x)
       (action:ord? x)
       (action:post? x)))
 
@@ -268,6 +271,8 @@ A RepConstraint is one of
      (pattern-attrs sp)]
     [(action:do _)
      null]
+    [(action:undo _)
+     null]
     [(action:ord sp _ _)
      (pattern-attrs sp)]
     [(action:post sp)
@@ -343,6 +348,7 @@ A RepConstraint is one of
     [(action:and ps) (ormap pattern-has-cut? ps)]
     [(action:parse sp _) (pattern-has-cut? sp)]
     [(action:do _) #f]
+    [(action:undo _) #f]
     [(action:ord sp _ _) (pattern-has-cut? sp)]
     [(action:post sp) (pattern-has-cut? sp)]
 
@@ -484,6 +490,7 @@ A RepConstraint is one of
         [(action:and? p) (patterns-AF (action:and-patterns p))]
         [(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)]
         [(action:do? p) AF-NONE]
+        [(action:undo? p) AF-SUB]
         [(action:ord? p) (pattern-AF (action:ord-pattern p))]
         [(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)]
         ;; Head patterns, eh patterns, etc

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

@@ -121,6 +121,7 @@
         (quote-syntax ~fail)
         (quote-syntax ~parse)
         (quote-syntax ~do)
+        (quote-syntax ~undo)
         (quote-syntax ...+)
         (quote-syntax ~delimit-cut)
         (quote-syntax ~commit)
@@ -459,7 +460,7 @@
   (define not-shadowed? (make-not-shadowed? decls))
   (check-pattern
   (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe
-                     ~seq ~optional ~! ~bind ~fail ~parse ~do
+                     ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo
                      ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
                      ~splicing-reflect)
                 (make-not-shadowed-id=? decls)
@@ -578,6 +579,10 @@
      (disappeared! stx)
      (check-action!
       (parse-pat:do stx decls))]
+    [(~undo . rest)
+     (disappeared! stx)
+     (check-action!
+      (parse-pat:undo stx decls))]
     [(head dots . tail)
      (and (dots? #'dots) (not-shadowed? #'dots))
      (begin (disappeared! #'dots)
@@ -1087,6 +1092,13 @@
     [_
      (wrong-syntax stx "bad ~~do pattern")]))
 
+(define (parse-pat:undo stx decls)
+  (syntax-case stx ()
+    [(_ stmt ...)
+     (action:undo (syntax->list #'(stmt ...)))]
+    [_
+     (wrong-syntax stx "bad ~~undo pattern")]))
+
 (define (parse-pat:rest stx decls)
   (syntax-case stx ()
     [(_ pattern)
@@ -1252,6 +1264,9 @@
     [(cons (list '#:do do-stx stmts) rest)
      (cons (action:do stmts)
            (parse-pattern-sides rest decls))]
+    [(cons (list '#:undo undo-stx stmts) rest)
+     (cons (action:undo stmts)
+           (parse-pattern-sides rest decls))]
     ['()
      '()]))
 
@@ -1616,7 +1631,8 @@
         (list '#:attr check-attr-arity check-expression)
         (list '#:and check-expression)
         (list '#:post check-expression)
-        (list '#:do check-stmt-list)))
+        (list '#:do check-stmt-list)
+        (list '#:undo check-stmt-list)))
 
 ;; fail-directive-table
 (define fail-directive-table

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

@@ -300,3 +300,8 @@
                        ;; that *should* have been cancelled out by ineffable pair failures.
                        |#)
                    (values 'fail (failure pr es)))])))))
+
+(provide illegal-cut-error)
+
+(define (illegal-cut-error . _)
+  (error 'syntax-parse "illegal use of cut"))