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

syntax/parse: add unwindable state: syntax-parse-state-{ref,set!,...}

Browse Source
This commit is contained in:
Ryan Culpepper 2017-12-15 23:39:40 +01:00 committed by Georges Dupéron
parent 785ffdacce
commit 40bfaced34
3 changed files with 78 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
parse/pre.rkt
View File

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

15
parse/private/parse.rkt
View File

@ -449,7 +449,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])
@ -597,7 +599,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))]
@ -790,7 +794,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])

31
parse/private/residual.rkt
View File

@ -315,10 +315,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)))))