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

syntax/parse: add groups of post progress

Browse Source 
This is a partial solution to the ~and problem, only for side clauses.
In (~and p1 p2 p3), one often wants errors in p2 to take precedence over
errors in p1, and likewise for p3 over p2. One solution is ~commit, but
that prevents backtracking. Another is ~post, but then two ~post wrappers
are needed around p3. Also, it doesn't make sense to compare progress of
the third #:with clause from stxclass A to the second #:with clause of
stxclass B and say third beats second.

So, generalize 'post to (post group index); post frames are comparable to
each other only if group is the same, then compared by index. (Post still
beats CAR and CDR.) Each set of side clauses shares a group.

For simplicity of code generation for now, use gensyms to identify groups.
This commit is contained in:
Ryan Culpepper 2016-04-16 23:58:19 -04:00
parent 51061c0829
commit 4e6438eaf2
6 changed files with 84 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
pkgs/racket-test/tests/stxparse/select.rkt
View File

@ -232,3 +232,35 @@
#rx"expected (B|C)"
#rx"while parsing A"
(not #rx"while parsing (B|C)")))
;; ------------------------------------------------------------
;; Regression tests
;; 4/16/2016, distilled from report by stchang
;; Want error message in second side clause to take precedence over
;; ellipsis-matching failures in first side clause.
(test-case "side-clauses order 1"
(check-exn #rx"unhappy about last number"
(lambda ()
(syntax-parse #'(1 2 3 4)
[(x:nat ...)
#:with (y ... z) #'(x ...)
#:fail-unless (>= (syntax->datum #'z) 10)
"unhappy about last number"
'ok]))))
(test-case "side-clauses order 2"
(check-exn (lambda (exn)
(and (regexp-match? #rx"unhappy about last number" (exn-message exn))
(exn:fail:syntax? exn)
(let* ([terms (exn:fail:syntax-exprs exn)]
[term (and (pair? terms) (syntax->datum (car terms)))])
(check-equal? term '4))))
(lambda ()
(syntax-parse #'(1 2 3 4)
[(x:nat ...)
#:with (y ... z) #'(x ...)
#:fail-when (and (< (syntax->datum #'z) 10) #'z)
"unhappy about last number"
'ok]))))

4
racket/collects/syntax/parse/private/parse.rkt
View File

@ -732,8 +732,8 @@ Conventions:
(parse:S y cy pattern pr* es k))]
[#s(action:do _ (stmt ...))
#'(let () (no-shadow stmt) ... (#%expression k))]
[#s(action:post _ pattern)
#'(let ([pr* (ps-add-post pr)])
[#s(action:post _ pattern group index)
#'(let ([pr* (ps-add-post pr 'group 'index)])
(parse:A x cx pattern pr* es k))])]))
;; (bind/sides clauses k) : expr[Ans]

8
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -79,7 +79,7 @@ A ActionPattern is one of
* (action:and Base (listof ActionPattern))
(action:parse Base SinglePattern stx)
(action:do Base (listof stx))
(action:post Base ActionPattern)
(action:post Base ActionPattern Quotable Nat)
action:and is desugared below in create-* procedures
|#
@ -90,7 +90,7 @@ action:and is desugared below in create-* procedures
(define-struct action:and (attrs patterns) #:prefab)
(define-struct action:parse (attrs pattern expr) #:prefab)
(define-struct action:do (attrs stmts) #:prefab)
(define-struct action:post (attrs pattern) #:prefab)
(define-struct action:post (attrs pattern group index) #:prefab)
#|
A HeadPattern is one of
@ -333,8 +333,8 @@ A SideClause is one of
(define (create-action:do stmts)
(make action:do null stmts))
(define (create-action:post pattern)
(make action:post (pattern-attrs pattern) pattern))
(define (create-action:post pattern group index)
(make action:post (pattern-attrs pattern) pattern group index))
;; ----

11
racket/collects/syntax/parse/private/rep.rkt
View File

@ -399,16 +399,19 @@
;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern
(define (combine-pattern+sides pattern sides splicing?)
(define sides-group (gensym))
(define actions-pattern
(create-action:and
(for/list ([side (in-list sides)])
(for/list ([side (in-list sides)] [index (in-naturals)])
(match side
[(clause:fail condition message)
(create-action:post
(create-action:fail condition message))]
(create-action:fail condition message)
sides-group index)]
[(clause:with wpat expr defs)
(let ([ap (create-action:post
(create-action:parse wpat expr))])
(create-action:parse wpat expr)
sides-group index)])
(if (pair? defs)
(create-action:and (list (create-action:do defs) ap))
ap))]
@ -1042,7 +1045,7 @@
[(_ pattern)
(let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)])
(cond [(action-pattern? p)
(cond [allow-action? (create-action:post p)]
(cond [allow-action? (create-action:post p #f 0)]
[(not allow-head?) (create-pat:post (action-pattern->single-pattern p))]
[else (wrong-syntax stx "action pattern not allowed here")])]
[(head-pattern? p)

10
racket/collects/syntax/parse/private/runtime-progress.rkt
View File

@ -10,6 +10,7 @@
ps-add-unvector
ps-add-unpstruct
ps-add-opaque
(struct-out post)
ps-pop-opaque
ps-context-syntax
@ -52,10 +53,10 @@ A FailFunction = (FailureSet -> Answer)
Progress (PS) is a non-empty list of Progress Frames (PF).
A Progress Frame (PF) is one of
- stx ;; "Base" frame
- stx ;; "Base" frame, or ~parse/#:with term
- 'car ;; car of pair; also vector->list, unbox, struct->list, etc
- nat ;; Represents that many repeated cdrs
- 'post
- #s(post group index) ;; late/post-traversal check, only comparable w/in group
- 'opaque
The error-reporting context (ie, syntax-parse #:context arg) is always
@ -76,6 +77,7 @@ Interpretation: later frames are applied first.
means ( car of ( cdr once of stx ) )
NOT apply car, then apply cdr once, then stop
|#
(define-struct post (group index) #:prefab)
(define (ps-empty stx ctx)
(if (eq? stx ctx)
@ -91,8 +93,8 @@ Interpretation: later frames are applied first.
(cons (+ times n) (cdr parent))]
[_
(cons times parent)])))
(define (ps-add-post parent)
(cons 'post parent))
(define (ps-add-post parent [group #f] [index 0])
(cons (post group index) parent))
(define (ps-add-stx parent stx)
(cons stx parent))
(define (ps-add-unbox parent)

41
racket/collects/syntax/parse/private/runtime-report.rkt
View File

@ -93,6 +93,8 @@ Progress ordering
Lexicographic generalization of partial order on frames
CAR < CDR < POST, stx incomparable except to self
(post g i1) < (post g i2) if i1 < i2
(post g1 i1) incomp (post g2 i2) when g1 != g2
Progress equality
-----------------
@ -148,7 +150,7 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
[(exact-positive-integer? (car ips))
(set! rCDR (cons a+ips rCDR))
(set! leastCDR (if leastCDR (min leastCDR (car ips)) (car ips)))]
[(eq? (car ips) 'post)
[(post? (car ips))
(set! rPOST (cons a+ips rPOST))]
[(syntax? (car ips))
(set! rSTX (cons a+ips rSTX))]
@ -159,7 +161,7 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
;; maximal/pf : (listof (cons A IPS))^4 & nat/#f -> (listof (listof A))
(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
(cond [(pair? rPOST)
(maximal/progress (rmap pop-item-ips rPOST))]
(maximal/post rPOST)]
[(pair? rCDR)
(maximal/progress (rmap (lambda (a+ips) (pop-item-ips-ncdrs a+ips leastCDR)) rCDR))]
[(pair? rCAR)
@ -169,6 +171,32 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
[else
null]))
;; maximal/post : (NEListof (cons A IPS)) -> (NEListof (NEListof A))
;; PRE: Each IPS starts with a post frame.
(define (maximal/post items)
;; groups : (Listof (Listof (cons A IPS)))
(define groups (group-by (lambda (a+ips) (post-group (car (cdr a+ips)))) items))
(define groups* (map post-group-max-items groups))
(append*
(for/list ([group (in-list groups*)])
(maximal/progress (map pop-item-ips group)))))
;; post-group-max-items : (NEListof (cons A IPS)) -> (Listof (cons A IPS))
;; PRE: Each IPS starts with a post frame; all items have same post-group.
;; Keep only items with max post-index.
(define (post-group-max-items items)
(let loop ([items items] [best-items null] [best-index -inf.0])
(cond [(null? items) (reverse best-items)]
[else
(define item0 (car items))
(define index0 (post-index (car (cdr item0))))
(cond [(> index0 best-index)
(loop (cdr items) (list item0) index0)]
[(= index0 best-index)
(loop (cdr items) (cons item0 best-items) best-index)]
[else
(loop (cdr items) best-items best-index)])])))
;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A))
(define (maximal/stx rSTX)
(let ([stxs null]
@ -215,7 +243,7 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
[(cons (? exact-positive-integer? n) parent)
(for/fold ([stx (interp parent)]) ([i (in-range n)])
(stx-cdr stx))]
[(cons 'post parent)
[(cons (? post?) parent)
(interp parent)]))
(let ([ps (ps-truncate-opaque ps)])
(match ps
@ -225,7 +253,7 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
(cons (interp ps) 0)]
[(cons (? exact-positive-integer? n) parent)
(cons (interp parent) n)]
[(cons 'post parent)
[(cons (? post?) parent)
(ps->stx+index parent)])))
(define (rmap f xs)
@ -738,7 +766,4 @@ This suggests the following new algorithm based on (s):
(for/list ([pf (in-list (reverse ps))])
(match pf
[(? syntax? stx) 'stx]
['car 'car]
['post 'post]
[(? exact-positive-integer? n) n]
['opaque 'opaque])))
[_ pf])))