From c61353a0f879da7876ff57db30e3aaf141823d34 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 27 Nov 2017 16:59:10 +0100
Subject: [PATCH] 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.
---
 parse/private/parse.rkt    |  4 ++++
 parse/private/rep.rkt      | 20 ++++++++++++++++++--
 parse/private/residual.rkt |  5 +++++
 3 files changed, 27 insertions(+), 2 deletions(-)

diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt
index 266d2bb..17c996c 100644
--- a/parse/private/parse.rkt
+++ b/parse/private/parse.rkt
@@ -777,6 +777,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))]
diff --git a/parse/private/rep.rkt b/parse/private/rep.rkt
index 34dca77..cec707a 100644
--- a/parse/private/rep.rkt
+++ b/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
diff --git a/parse/private/residual.rkt b/parse/private/residual.rkt
index beafc67..d3d6e2c 100644
--- a/parse/private/residual.rkt
+++ b/parse/private/residual.rkt
@@ -309,3 +309,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"))