suzanne.soy/stxparse-info
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: make undo cooperate with ~commit and ~! (cut)

Browse Source
This commit is contained in:
Ryan Culpepper 2017-12-09 00:55:31 +01:00 committed by Georges Dupéron
parent c61353a0f8
commit bf47b22091
9 changed files with 120 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
parse/debug.rkt
View File

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

2
parse/experimental/provide.rkt
View File

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

4
parse/experimental/reflect.rkt
View File

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

4
parse/experimental/specialize.rkt
View File

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

10
parse/experimental/splicing.rkt
View File

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

122
parse/private/parse.rkt
View File

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

13
parse/private/residual.rkt
View File

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

12
parse/private/runtime-reflect.rkt
View File

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

30
parse/private/runtime.rkt
View File

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