From 5db8553ea17498c4f6c7e45fe3b68cbae56d811d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 13 Mar 2012 18:29:09 -0600 Subject: [PATCH] syntax/parse: expect:thing stores stx being matched --- .../syntax/parse/experimental/splicing.rkt | 2 +- collects/syntax/parse/private/parse.rkt | 10 +++--- collects/syntax/parse/private/residual.rkt | 2 +- .../syntax/parse/private/runtime-progress.rkt | 35 +++++++++++++------ .../syntax/parse/private/runtime-report.rkt | 35 ++++++++++++++----- 5 files changed, 58 insertions(+), 26 deletions(-) diff --git a/collects/syntax/parse/experimental/splicing.rkt b/collects/syntax/parse/experimental/splicing.rkt index 64a5e63ec6..c2c3cc792d 100644 --- a/collects/syntax/parse/experimental/splicing.rkt +++ b/collects/syntax/parse/experimental/splicing.rkt @@ -50,7 +50,7 @@ ((error) (let ([es (list* (expect:message (cadr result)) - (expect:thing (get-description param ...) #f rl) + (expect:thing pr (get-description param ...) #f rl) es)]) (fh (failure pr es)))))))))) (define-syntax name diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index eb7967a943..a39175dbf6 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -76,7 +76,7 @@ (define (parser x cx pr es fh0 cp0 rl success) (if (predicate x) (success fh0) - (let ([es (cons (expect:thing 'description #t rl) es)]) + (let ([es (cons (expect:thing pr 'description #t rl) es)]) (fh0 (failure pr es)))))))])) (define-syntax (parser/rhs stx) @@ -260,7 +260,7 @@ Conventions: (syntax-parameterize ((this-context-syntax (syntax-rules () [(tbs) (ps-context-syntax pr)]))) - (let ([es (cons (expect:thing description 'transparent? rl) es)] + (let ([es (cons (expect:thing pr description 'transparent? rl) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (with ([fail-handler fh0] [cut-prompt cp0]) @@ -549,7 +549,7 @@ Conventions: (parse:S datum scx subpattern pr es k)) (fail (failure pr es))))] [#s(pat:describe attrs pattern description transparent? role) - #`(let ([es (cons (expect:thing description transparent? role) es)] + #`(let ([es (cons (expect:thing pr description transparent? role) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (parse:S x cx pattern pr es k))] [#s(pat:delimit attrs pattern) @@ -575,7 +575,7 @@ Conventions: #'(let ([x* (datum->syntax cx x cx)]) (if (predicate x*) (let-attributes (name-attr ...) k) - (let ([es (cons (expect:thing 'description #t role) es)]) + (let ([es (cons (expect:thing pr 'description #t role) es)]) (fail (failure pr es))))))])])) ;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans] @@ -669,7 +669,7 @@ Conventions: [(parse:H x cx rest-x rest-cx rest-pr head pr es k) (syntax-case #'head () [#s(hpat:describe _ pattern description transparent? role) - #`(let ([es* (cons (expect:thing description transparent? role) es)] + #`(let ([es* (cons (expect:thing pr description transparent? role) es)] [pr (if 'transparent? pr (ps-add-opaque pr))]) (parse:H x cx rest-x rest-cx rest-pr pattern pr es* (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) diff --git a/collects/syntax/parse/private/residual.rkt b/collects/syntax/parse/private/residual.rkt index 4f244b6ed5..f5682ce155 100644 --- a/collects/syntax/parse/private/residual.rkt +++ b/collects/syntax/parse/private/residual.rkt @@ -215,7 +215,7 @@ (loop (cdr x) cx (add1 i)) (let* ([pr (ps-add-cdr pr i)] [pr (ps-add-car pr)] - [es (cons (expect:thing desc #t rl) es)]) + [es (cons (expect:thing pr desc #t rl) es)]) (values 'fail (failure pr es))))] [else ;; not null, because stx->list failed (let ([pr (ps-add-cdr pr i)] diff --git a/collects/syntax/parse/private/runtime-progress.rkt b/collects/syntax/parse/private/runtime-progress.rkt index 455627cc3c..4d04e932d9 100644 --- a/collects/syntax/parse/private/runtime-progress.rkt +++ b/collects/syntax/parse/private/runtime-progress.rkt @@ -30,23 +30,29 @@ #| Progress (PS) is a non-empty list of Progress Frames (PF). -A PF is one of +A Progress Frame (PF) is one of - stx ;; "Base" frame - - 'car + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc - nat ;; Represents that many repeated cdrs - 'post - 'opaque -stx frame introduced +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced - always at base (that is, by syntax-parse) - if syntax-parse has #:context arg, then two stx frames at bottom: (list to-match-stx context-stx) - by #:with/~parse - by #:fail-*/#:when/~fail & stx -Interpretation: Inner PS structures are applied first. - eg, (list 'car 1 #'___) - means ( car of ( cdr once of the term ) ) +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) NOT apply car, then apply cdr once, then stop |# @@ -154,6 +160,7 @@ Interpretation: Inner PS structures are applied first. (reverse (ps-truncate-opaque ps))) ;; ps-pop-opaque : PS -> IPS +;; Used to continue with progress from opaque head pattern. (define (ps-pop-opaque ps) (match ps [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) @@ -164,7 +171,8 @@ Interpretation: Inner PS structures are applied first. ;; ==== Failure ==== -;; A Failure is (make-failure PS ExpectStack) +;; A Failure is (failure PS ExpectStack) + ;; A FailureSet is one of ;; - Failure ;; - (cons FailureSet FailureSet) @@ -181,15 +189,19 @@ Interpretation: Inner PS structures are applied first. An ExpectStack is (listof Expect) An Expect is one of - - (make-expect:thing string boolean string/#f) + - (make-expect:thing ??? string boolean string/#f) * (make-expect:message string) * (make-expect:atom atom) * (make-expect:literal identifier) * (make-expect:disj (non-empty-listof Expect)) The *-marked variants can only occur at the top of the stack. + +expect:thing frame contains representation of term: + - during parsing, represent as progress + - during reporting, convert to stx |# -(define-struct expect:thing (description transparent? role) #:prefab) +(define-struct expect:thing (term description transparent? role) #:prefab) (define-struct expect:message (message) #:prefab) (define-struct expect:atom (atom) #:prefab) (define-struct expect:literal (literal) #:prefab) @@ -226,7 +238,10 @@ The *-marked variants can only occur at the top of the stack. (map expect->sexpr es)) (define (expect->sexpr e) - e) + (match e + [(expect:thing term description transparent? role) + (expect:thing ' description transparent? role)] + [else e])) (define (progress->sexpr ps) (for/list ([pf (in-list (invert-ps ps))]) diff --git a/collects/syntax/parse/private/runtime-report.rkt b/collects/syntax/parse/private/runtime-report.rkt index 8e610354c2..77963a9659 100644 --- a/collects/syntax/parse/private/runtime-report.rkt +++ b/collects/syntax/parse/private/runtime-report.rkt @@ -12,8 +12,8 @@ exn:syntax-parse-info) #| -TODO: given (expect:thing D _ R) and (expect:thing D _ #f), - simplify to (expect:thing D _ #f) +TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f), + simplify to (expect:thing _ D _ #f) thus, "expected D" rather than "expected D or D for R" (?) |# @@ -113,7 +113,7 @@ complicated. ;; prose-for-expect : Expect -> string (define (prose-for-expect e) (match e - [(expect:thing description transparent? role) + [(expect:thing ??? description transparent? role) (if role (format "expected ~a for ~a" description role) (format "expected ~a" description))] @@ -159,7 +159,6 @@ complicated. ;; ==== Failure analysis ==== - ;; == Failure simplification == ;; maximal-failures : FailureSet -> (listof (listof Failure)) @@ -173,7 +172,9 @@ complicated. ;; normalize-expectstack : ExpectStack -> ExpectStack (define (normalize-expectstack es) - (filter-expectstack (truncate-opaque-expectstack es))) + (convert-expectstack + (filter-expectstack + (truncate-opaque-expectstack es)))) ;; truncate-opaque-expectstack : ExpectStack -> ExpectStack ;; Eliminates expectations on top of opaque (ie, transparent=#f) frames. @@ -182,20 +183,37 @@ complicated. (let loop ([es es]) (match es ['() '()] - [(cons (expect:thing description '#f role) rest-es) + [(cons (expect:thing ps description '#f role) rest-es) ;; Tricky! If multiple opaque frames, multiple "returns", ;; but innermost one called first, so jumps past the rest. ;; Also, flip opaque to transparent for sake of equality. - (return (cons (expect:thing description #t role) (loop rest-es)))] + (return (cons (expect:thing ps description #t role) (loop rest-es)))] + [(cons (expect:thing ps description '#t role) rest-es) + (cons (expect:thing ps description #t role) (loop rest-es))] [(cons expect rest-es) (cons expect (loop rest-es))])))) +;; convert-expectstack : ExpectStack -> ExpectStack +;; Converts expect:thing term rep from progress to (cons stx index). +(define (convert-expectstack es) + (define (convert-ps ps) + (let-values ([(stx index) (ps->stx+index ps)]) + (cons stx index))) + (map (lambda (expect) + (match expect + [(expect:thing ps de tr? rl) + (expect:thing (convert-ps ps) de tr? rl)] + [_ expect])) + es)) + ;; filter-expectstack : ExpectStack -> ExpectStack ;; Eliminates missing (ie, #f) messages and descriptions +;; FIXME: Change parsing code to avoid useless frame allocations? +;; Or are they worth retaining for debugging? (define (filter-expectstack es) (filter (lambda (expect) (match expect - [(expect:thing '#f _) + [(expect:thing _ '#f _ _) #f] [(expect:message '#f) #f] @@ -220,7 +238,6 @@ So we go with option 2. |# ;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack) -;; Should call remove-duplicates first. (define (simplify-common-expectstacks ess) ;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack) (define (simplify ress)