commit bf47b2209111438e0d541a2ef3c5ad74115c360a
parent c61353a0f879da7876ff57db30e3aaf141823d34
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sat, 9 Dec 2017 00:55:31 +0100
syntax/parse: make undo cooperate with ~commit and ~! (cut)
Diffstat:
9 files changed, 120 insertions(+), 81 deletions(-)
diff --git a/parse/debug.rkt b/parse/debug.rkt
@@ -43,8 +43,8 @@
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (fs) fs)])
- (app-argu parser x x (ps-empty x x) #f fh fh #f
- (lambda (fh . attr-values)
+ (app-argu parser x x (ps-empty x x) #f null fh fh #f
+ (lambda (fh undos . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu))))))]))
diff --git a/parse/experimental/provide.rkt b/parse/experimental/provide.rkt
@@ -84,7 +84,7 @@
[opc-id opc] ...
[okwc-id okwc] ...)
(rename-contract
- (->* (any/c any/c any/c any/c any/c any/c any/c any/c
+ (->* (any/c any/c any/c any/c any/c any/c any/c any/c any/c
mpc-id ... mkw-c-part ... ...)
(okw-c-part ... ...)
any)
diff --git a/parse/experimental/reflect.rkt b/parse/experimental/reflect.rkt
@@ -73,9 +73,9 @@
(arity minpos* maxpos* minkws* maxkws*))])]
[curried-parser
(make-keyword-procedure
- (lambda (kws2 kwargs2 x cx pr es fh cp rl success . rest2)
+ (lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
- (keyword-apply parser kws kwargs x cx pr es fh cp rl success
+ (keyword-apply parser kws kwargs x cx pr es undos fh cp rl success
(append rest1 rest2)))))]
[ctor
(cond [(reified-syntax-class? r)
diff --git a/parse/experimental/specialize.rkt b/parse/experimental/specialize.rkt
@@ -36,5 +36,5 @@
'splicing?
'opts #f))
(define-values (parser)
- (lambda (x cx pr es fh0 cp0 rl success . formals)
- (app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))
+ (lambda (x cx pr es undos fh0 cp0 rl success . formals)
+ (app-argu target-parser x cx pr es undos fh0 cp0 rl success argu))))))))])))
diff --git a/parse/experimental/splicing.rkt b/parse/experimental/splicing.rkt
@@ -35,7 +35,7 @@
description)
(define parser
(let ([permute (mk-permute '(a.name ...))])
- (lambda (x cx pr es fh _cp rl success param ...)
+ (lambda (x cx pr es undos fh _cp rl success param ...)
(let ([stx (datum->syntax cx x cx)])
(let ([result
(let/ec escape
@@ -46,13 +46,13 @@
(case (car result)
((ok)
(apply success
- ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh)
+ ((mk-check-result pr 'name (length '(a.name ...)) permute x cx undos fh)
(cdr result))))
((error)
(let ([es
(es-add-message (cadr result)
(es-add-thing pr (get-description param ...) #f rl es))])
- (fh (failure pr es))))))))))
+ (fh undos (failure pr es))))))))))
(define-syntax name
(stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
(sort-sattrs '(#s(attr a.name a.depth #f) ...))
@@ -76,7 +76,7 @@
(for/list ([index (in-vector indexes)])
(list-ref result index)))))))
-(define (mk-check-result pr name attr-count permute x cx fh)
+(define (mk-check-result pr name attr-count permute x cx undos fh)
(lambda (result)
(unless (list? result)
(error name "parser returned non-list"))
@@ -91,5 +91,5 @@
(error name "expected exact nonnegative integer for first element of result list, got ~e"
skip))
(let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
- (list* fh rest-x rest-cx (ps-add-cdr pr skip)
+ (list* fh undos rest-x rest-cx (ps-add-cdr pr skip)
(permute (cdr result))))))))
diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt
@@ -89,11 +89,11 @@
#f
(scopts 0 #t #t 'description)
(quote-syntax predicate)))
- (define (parser x cx pr es fh0 cp0 rl success)
+ (define (parser x cx pr es undos fh0 cp0 rl success)
(if (predicate x)
- (success fh0)
+ (success fh0 undos)
(let ([es (es-add-thing pr 'description #t rl es)])
- (fh0 (failure* pr es)))))))]))
+ (fh0 undos (failure* pr es)))))))]))
(define-syntax (parser/rhs stx)
(syntax-case stx ()
@@ -155,7 +155,7 @@
[transparent? transparent?]
[delimit-cut? delimit-cut?]
[body body])
- #`(lambda (x cx pr es fh0 cp0 rl success . formals*)
+ #`(lambda (x cx pr es undos fh0 cp0 rl success . formals*)
(with ([this-syntax x]
[this-role rl])
def ...
@@ -168,7 +168,8 @@
#,(if no-fail? #'#f #'es))]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(with ([fail-handler fh0]
- [cut-prompt cp0])
+ [cut-prompt cp0]
+ [undo-stack undos])
;; Update the prompt, if required
;; FIXME: can be optimized away if no cut exposed within variants
(with-maybe-delimit-cut delimit-cut?
@@ -230,7 +231,8 @@
def ...
(#%expression
(with ([fail-handler fh0]
- [cut-prompt fh0])
+ [cut-prompt fh0]
+ [undo-stack null])
(parse:S x cx pattern pr es
(list (attribute name) ...)))))))))))]))
@@ -251,18 +253,24 @@ Parsing protocols:
pr, es are progress and expectstack, respectively
rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr
-(stxclass-parser x cx pr es fail-handler cut-prompt role success-proc arg ...) : Ans
+(stxclass-parser x cx pr es undos fail-handler cut-prompt role success-proc arg ...) : Ans
success-proc:
- for stxclass, is (fail-handler attr-value ... -> Ans)
- for splicing-stxclass, is (fail-handler rest-x rest-cx rest-pr attr-value -> Ans)
- fail-handler, cut-prompt : failure -> Ans
+ for stxclass, is (fail-handler undos attr-value ... -> Ans)
+ for splicing-stxclass, is (undos fail-handler rest-x rest-cx rest-pr attr-value -> Ans)
+ fail-handler, cut-prompt : undos failure -> Ans
Fail-handler is normally represented with stxparam 'fail-handler', but must be
threaded through stxclass calls (in through stxclass-parser, out through
success-proc) to support backtracking. Cut-prompt is never changed within
stxclass or within alternative, so no threading needed.
+The undo stack is normally represented with stxparam 'undo-stack', but must be
+threaded through stxclass calls (like fail-handler). A failure handler closes
+over a base undo stack and receives an extended current undo stack; the failure
+handler unwinds effects by performing every action in the difference between
+them and then restores the saved undo stack.
+
Usually sub-patterns processed in tail position, but *can* do non-tail calls for:
- ~commit
- var of stxclass with ~commit
@@ -368,7 +376,7 @@ Conventions:
(reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
- #'(success fail-handler also ... (attribute name) ...)))]))
+ #'(success fail-handler undo-stack also ... (attribute name) ...)))]))
;; ----
@@ -443,7 +451,8 @@ Conventions:
def ...
(parameterize ((current-syntax-context (cadr ctx0)))
(with ([fail-handler fh0]
- [cut-prompt fh0])
+ [cut-prompt fh0]
+ [undo-stack null])
#,(cond [(pair? patterns)
(with-syntax ([matrix
(optimize-matrix
@@ -537,26 +546,31 @@ Conventions:
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
- #'(app-argu parser x cx pr es fail-handler cut-prompt role
- (lambda (fh av ...)
+ #'(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role
+ (lambda (fh undos av ...)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
- (with ([fail-handler fh])
+ (with ([fail-handler fh] [undo-stack undos])
k))))
argu)
;; The commit protocol
;; (Avoids putting k in procedure)
- #'(let-values ([(fs av ...)
- (with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))])
+ #'(let-values ([(fs undos av ...)
+ (with ([fail-handler
+ (lambda (undos fs)
+ (unwind-to undos undo-stack)
+ (values fs undo-stack (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
- (app-argu parser x cx pr es fail-handler cut-prompt role
- (lambda (fh av ...) (values #f av ...))
+ (app-argu parser x cx pr es undo-stack
+ fail-handler cut-prompt role
+ (lambda (fh undos av ...) (values #f undos av ...))
argu)))])
(if fs
(fail fs)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
- k))))))]
+ (with ([undo-stack undos])
+ k)))))))]
[#s(pat:reflect obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
@@ -564,11 +578,11 @@ Conventions:
#'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)])
- (app-argu parser x cx pr es fail-handler cut-prompt #f
- (lambda (fh . result)
+ (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f
+ (lambda (fh undos . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
- (with ([fail-handler fh])
+ (with ([fail-handler fh] [undo-stack undos])
k))))
argu))))]
[#s(pat:datum datum)
@@ -598,9 +612,9 @@ Conventions:
[#s(pat:or (a ...) (subpattern ...) (subattrs ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
- (lambda (fh id ...)
+ (lambda (fh undos id ...)
(let-attributes ([a id] ...)
- (with ([fail-handler fh])
+ (with ([fail-handler fh] [undo-stack undos])
k)))])
(try (parse:S x cx subpattern pr es
(disjunct subattrs success () (id ...)))
@@ -610,14 +624,14 @@ Conventions:
[pr0 pr]
[es0 es]
[fail-to-succeed
- (lambda (fs) k)])
+ (lambda (undos fs) (unwind-to undos undo-stack) k)])
;; ~not implicitly prompts to be safe,
;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
;; (statically checked!)
(with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe
(parse:S x cx subpattern pr es
- (fh0 (failure* pr0 es0)))))]
+ (fh0 undo-stack (failure* pr0 es0)))))]
[#s(pat:pair head tail)
#`(let ([datum (if (syntax? x) (syntax-e x) x)]
[cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?!
@@ -748,7 +762,7 @@ Conventions:
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
- (success fail-handler pre ... id ...)))))]))
+ (success fail-handler undo-stack pre ... id ...)))))]))
;; (parse:A x cx A-pattern pr es k) : expr[Ans]
;; In k: attrs(A-pattern) are bound.
@@ -778,9 +792,9 @@ Conventions:
[#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))))]
+ #'(with ([undo-stack (cons (lambda () stmt ... (void)) undo-stack)]
+ [cut-prompt illegal-cut-error])
+ k)]
[#s(action:ord pattern group index)
#'(let ([pr* (ps-add pr '#s(ord group index))])
(parse:A x cx pattern pr* es k))]
@@ -831,27 +845,32 @@ Conventions:
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
- #`(app-argu parser x cx pr es fail-handler cut-prompt role
- (lambda (fh rest-x rest-cx rest-pr av ...)
+ #`(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role
+ (lambda (fh undos rest-x rest-cx rest-pr av ...)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
- (with ([fail-handler fh])
+ (with ([fail-handler fh] [undo-stack undos])
k))))
argu)
;; The commit protocol
;; (Avoids putting k in procedure)
- #'(let-values ([(fs rest-x rest-cx rest-pr av ...)
- (with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))])
+ #'(let-values ([(fs undos rest-x rest-cx rest-pr av ...)
+ (with ([fail-handler
+ (lambda (undos fs)
+ (unwind-to undos undo-stack)
+ (values fs undo-stack #f #f #f (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
- (app-argu parser x cx pr es fail-handler cut-prompt role
- (lambda (fh rest-x rest-cx rest-pr av ...)
- (values #f rest-x rest-cx rest-pr av ...))
+ (app-argu parser x cx pr es undo-stack
+ fail-handler cut-prompt role
+ (lambda (fh undos rest-x rest-cx rest-pr av ...)
+ (values #f undos rest-x rest-cx rest-pr av ...))
argu)))])
(if fs
(fail fs)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
- k))))))]
+ (with ([undo-stack undos])
+ k)))))))]
[#s(hpat:reflect obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
@@ -860,11 +879,11 @@ Conventions:
#'())])
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)])
- (app-argu parser x cx pr es fail-handler cut-prompt #f
- (lambda (fh rest-x rest-cx rest-pr . result)
+ (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f
+ (lambda (fh undos rest-x rest-cx rest-pr . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
- (with ([fail-handler fh])
+ (with ([fail-handler fh] [undo-stack undos])
k))))
argu))))]
[#s(hpat:and head single)
@@ -875,9 +894,9 @@ Conventions:
[#s(hpat:or (a ...) (subpattern ...) (subattrs ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
- (lambda (fh rest-x rest-cx rest-pr id ...)
+ (lambda (fh undos rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...)
- (with ([fail-handler fh])
+ (with ([fail-handler fh] [undo-stack undos])
k)))])
(try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(disjunct subattrs success (rest-x rest-cx rest-pr) (id ...)))
@@ -921,7 +940,8 @@ Conventions:
[pr0 pr]
[es0 es]
[fail-to-succeed
- (lambda (fs)
+ (lambda (undos fs)
+ (unwind-to undos undo-stack)
(let ([rest-x x]
[rest-cx cx]
[rest-pr pr])
@@ -932,7 +952,7 @@ Conventions:
(with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe
(parse:H x cx rest-x rest-cx rest-pr subpattern pr es
- (fh0 (failure* pr0 es0)))))]
+ (fh0 undo-stack (failure* pr0 es0)))))]
[_
#'(parse:S x cx
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
@@ -999,11 +1019,11 @@ Conventions:
tail-pattern-is-null?])
(define/with-syntax alt-map #'((id . alt-id) ...))
(define/with-syntax loop-k
- #'(dots-loop dx* dcx* loop-pr* fail-handler rel-rep ... alt-id ...))
+ #'(dots-loop dx* dcx* loop-pr* undo-stack fail-handler rel-rep ... alt-id ...))
#`(let ()
;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
- (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...)
- (with ([fail-handler fh])
+ (define (dots-loop dx dcx loop-pr undos fh rel-rep ... alt-id ...)
+ (with ([fail-handler fh] [undo-stack undos])
(try-or-pair/null-check do-pair/null? dx dcx loop-pr es
(try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr*
alt-map head-rep head es loop-k)
@@ -1017,7 +1037,7 @@ Conventions:
(parse:S dx dcx tail loop-pr es k))]))))
(let ([rel-rep 0] ...
[alt-id (rep:initial-value attr-repc)] ...)
- (dots-loop x cx pr fail-handler rel-rep ... alt-id ...)))))]))
+ (dots-loop x cx pr undo-stack fail-handler rel-rep ... alt-id ...)))))]))
;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt)
(define-syntax try-or-pair/null-check
diff --git a/parse/private/residual.rkt b/parse/private/residual.rkt
@@ -279,8 +279,9 @@
["runtime-report.rkt"
(call-current-failure-handler ctx fs)])
-;; syntax-patterns-fail : (list Symbol/#f Syntax) -> FailureSet -> (escapes)
-(define ((syntax-patterns-fail ctx) fs)
+;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes
+(define ((syntax-patterns-fail ctx) undos fs)
+ (unwind-to undos null)
(call-current-failure-handler ctx fs))
;; == specialized ellipsis parser
@@ -314,3 +315,11 @@
(define (illegal-cut-error . _)
(error 'syntax-parse "illegal use of cut"))
+
+(provide unwind-to)
+
+(define (unwind-to undos base)
+ ;; PRE: undos = (list* proc ... base)
+ (unless (eq? undos base)
+ ((car undos))
+ (unwind-to (cdr undos) base)))
diff --git a/parse/private/runtime-reflect.rkt b/parse/private/runtime-reflect.rkt
@@ -82,13 +82,13 @@ A Reified is
[else
(loop (cdr result) indexes (add1 i))])))
(make-keyword-procedure
- (lambda (kws kwargs x cx pr es fh cp rl success . rest)
- (keyword-apply parser kws kwargs x cx pr es fh cp rl
+ (lambda (kws kwargs x cx pr es undos fh cp rl success . rest)
+ (keyword-apply parser kws kwargs x cx pr es undos fh cp rl
(if splicing?
- (lambda (fh x cx pr . result)
- (apply success fh x cx pr (take-indexes result indexes)))
- (lambda (fh . result)
- (apply success fh (take-indexes result indexes))))
+ (lambda (fh undos x cx pr . result)
+ (apply success fh undos x cx pr (take-indexes result indexes)))
+ (lambda (fh undos . result)
+ (apply success fh undos (take-indexes result indexes))))
rest))))))
(define (wrong-depth who a b)
diff --git a/parse/private/runtime.rkt b/parse/private/runtime.rkt
@@ -14,6 +14,7 @@
(provide with
fail-handler
cut-prompt
+ undo-stack
wrap-user-code
fail
@@ -59,29 +60,38 @@ residual.rkt.
(define-syntax-parameter cut-prompt
(lambda (stx)
(wrong-syntax stx "internal error: cut-prompt used out of context")))
+(define-syntax-parameter undo-stack
+ (lambda (stx)
+ (wrong-syntax stx "internal error: undo-stack used out of context")))
(define-syntax-rule (wrap-user-code e)
(with ([fail-handler #f]
- [cut-prompt #t])
+ [cut-prompt #t]
+ [undo-stack null])
e))
(define-syntax-rule (fail fs)
- (fail-handler fs))
+ (fail-handler undo-stack fs))
(define-syntax (try stx)
(syntax-case stx ()
[(try e0 e ...)
(with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
(with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
- (with-syntax ([(next-fh ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)]
- [(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)])
- #'(let* ([fh (lambda (fs1)
+ (with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)])
+ #'(let* ([fh (lambda (undos1 fs1)
(with ([fail-handler
- (lambda (fs2)
- (next-fh (cons fs1 fs2)))])
+ (lambda (undos2 fs2)
+ (unwind-to undos2 undos1)
+ (next-fh undos1 (cons fs1 fs2)))]
+ [undo-stack undos1])
re))]
...)
- (with ([fail-handler last-fh])
+ (with ([fail-handler
+ (lambda (undos2 fs2)
+ (unwind-to undos2 undo-stack)
+ (last-fh undo-stack fs2))]
+ [undo-stack undo-stack])
e0)))))]))
;; == Attributes
@@ -208,8 +218,8 @@ residual.rkt.
(length (syntax->list #'(parg ...)))
(syntax->datum #'(kw ...)))])
(with-syntax ([parser (stxclass-parser sc)])
- #'(lambda (x cx pr es fh cp rl success)
- (app-argu parser x cx pr es fh cp rl success argu)))))]))
+ #'(lambda (x cx pr es undos fh cp rl success)
+ (app-argu parser x cx pr es undos fh cp rl success argu)))))]))
(define-syntax (app-argu stx)
(syntax-case stx ()
