diff --git a/pkgs/racket-doc/syntax/scribblings/parse.scrbl b/pkgs/racket-doc/syntax/scribblings/parse.scrbl index e020d1df42..6026eaee6c 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse.scrbl @@ -23,6 +23,7 @@ messages embedded in the macro's syntax patterns. @include-section["parse/define.scrbl"] @include-section["parse/litconv.scrbl"] @include-section["parse/lib.scrbl"] +@include-section["parse/state.scrbl"] @;{Description of how error reporting works} @;{and designing for good errors} diff --git a/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl new file mode 100644 index 0000000000..68cb0566d7 --- /dev/null +++ b/pkgs/racket-doc/syntax/scribblings/parse/state.scrbl @@ -0,0 +1,53 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt") + +@(define the-eval (make-sp-eval)) + +@title[#:tag "state"]{Unwindable State} + +@declare-exporting[syntax/parse] + +@deftogether[[ +@defproc[(syntax-parse-state-ref [key any/c] + [default default/c (lambda () (error ....))]) + any/c] +@defproc[(syntax-parse-state-set! [key any/c] [value any/c]) void?] +@defproc[(syntax-parse-state-update! [key any/c] + [update (-> any/c any/c)] + [default default/c (lambda () (error ....))]) + void?] +@defproc[(syntax-parse-state-cons! [key any/c] + [value any/c] + [default default/c null]) + void?] +]]{ + +Get or update the current @racket[syntax-parse] state. Updates to the +state are unwound when @racket[syntax-parse] backtracks. Keys are +compared using @racket[eq?]. + +The state can be updated only within @racket[~do] patterns (or +@racket[#:do] blocks). In addition, @racket[syntax-parse] +automatically adds identifiers that match literals (from +@racket[~literal] patterns and literals declared with +@racket[#:literals], but not from @racket[~datum] or +@racket[#:datum-literals]) under the key @racket['literals]. + +@examples[#:eval the-eval +(define-syntax-class cond-clause + #:literals (=> else) + (pattern [test:expr => ~! answer:expr ...]) + (pattern [else answer:expr ...]) + (pattern [test:expr answer:expr ...])) +(syntax-parse #'(cond [A => B] [else C]) + [(_ c:cond-clause ...) (syntax-parse-state-ref 'literals null)]) +] + +@history[#:added "6.11.0.4"] +} + +@(close-eval the-eval) diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 0f22598f58..10315f7a2b 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -535,6 +535,31 @@ (check-equal? (reverse (lits)) '(a c)))) ) +;; state unwinding + +(let () + (define total + (case-lambda [() (syntax-parse-state-ref 'total 0)] + [(n) (syntax-parse-state-set! 'total n)])) + (define-syntax-class nat/add + (pattern n:nat #:do [(total (+ (total) (syntax-e #'n)))])) + (test-case "state 1" + (syntax-parse #'(1 2 3) + [(n:nat/add ...) (check-equal? (total) (+ 1 2 3))])) + (test-case "state 2" + (syntax-parse #'(1 2 3 reset 5 6) + [((~or (~seq) (~seq _ ... (~not _:nat))) n:nat/add ...) + (check-equal? (total) (+ 5 6))]))) + +(test-case "state and literals" + (check-equal? + (map syntax-e + (syntax-parse #'(define lambda) + #:literals (define lambda) + [(define define) (syntax-parse-state-ref 'literals null)] + [(_ lambda) (syntax-parse-state-ref 'literals null)])) + '(lambda))) + ;; == Lib tests ;; test string, bytes act as stxclasses diff --git a/racket/collects/syntax/parse/pre.rkt b/racket/collects/syntax/parse/pre.rkt index b9f801ed60..1ee5047490 100644 --- a/racket/collects/syntax/parse/pre.rkt +++ b/racket/collects/syntax/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)))) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index dfdc3fb2c6..23a69eef4a 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -443,7 +443,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]) @@ -591,7 +593,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))] @@ -784,7 +788,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]) diff --git a/racket/collects/syntax/parse/private/residual.rkt b/racket/collects/syntax/parse/private/residual.rkt index 75d942706d..a1fe5ff2d7 100644 --- a/racket/collects/syntax/parse/private/residual.rkt +++ b/racket/collects/syntax/parse/private/residual.rkt @@ -306,10 +306,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)))))