From 82e1e3308f8e34cb9beb10754554482a819d7840 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 2 Feb 2010 07:22:35 +0000 Subject: [PATCH] syntax/parse: fixed docs bug in ...+ fixed bug in rep constraint messages svn: r17938 --- collects/syntax/private/stxparse/parse.ss | 20 ++++---- .../syntax/private/stxparse/runtime-prose.ss | 50 ++++++++++++++++++- collects/syntax/private/stxparse/sc.ss | 5 +- .../syntax/scribblings/parse-patterns.scrbl | 22 +++++--- collects/syntax/scribblings/parse.scrbl | 2 +- 5 files changed, 80 insertions(+), 19 deletions(-) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index e4b34eacb7..dc872606cb 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -617,21 +617,23 @@ (define-syntax expectation-of-message/too-few (syntax-rules () [(emtf #f #f) - (collect-error "repetition constraint violated")] + (expectation-of-message "repetition constraint violated")] [(emtf #f name) - (collect-error (format "missing required occurrence of ~a" name))] + (expectation-of-message + (format "missing required occurrence of ~a" name))] [(emtf msg _) - (collect-error msg)])) + (expectation-of-message msg)])) (define-syntax expectation-of-message/too-many (syntax-rules () [(emtm #f #f) - (collect-error (format "repetition constraint violated"))] + (expectation-of-message + (format "repetition constraint violated"))] [(emtm #f name) - (collect-error (format "too many occurrences of ~a" name))] + (expectation-of-message + (format "too many occurrences of ~a" name))] [(emtm msg _) - (collect-error msg)])) - + (expectation-of-message msg)])) ;; @@ -648,9 +650,9 @@ (let ([b (syntax-local-value #'tmp)]) (syntax-case stx () [(ce thing) - (begin (set-box! b (cons #''thing (unbox b))) + (begin (set-box! b (cons #'thing (unbox b))) #'thing)] [(ce) (with-syntax ([(thing ...) (reverse (unbox b))]) - #'(list thing ...))]))))) + #'(list #'thing ...))]))))) body)))) diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss index 7cec766378..18bbd221f3 100644 --- a/collects/syntax/private/stxparse/runtime-prose.ss +++ b/collects/syntax/private/stxparse/runtime-prose.ss @@ -143,7 +143,8 @@ (for-alternative alt index stx)) ";" "or")))] [(eq? e 'ineffable) - #f])) + #f] + [else (error 'prose-for-expectation "unexpected: ~e" e)])) (define (for-alternative e index stx) (match e @@ -188,3 +189,50 @@ [(a . b) (cons #'a (improper-stx->list #'b))] [() null] [rest (list #'rest)])) + + +;; Ad-hoc interpretation of error message expressions +(provide interpret-error-expression) + +;; Recognize application of 'format' procedure +(define (interpret-error-expression e) + (define vars '(X Y Z)) + + ;; minieval : syntax -> (or syntax datum) + ;; Returns syntax on NON-evalable stuff, datum otherwise + (define (minieval x) + (syntax-case x (format quote datum literal) + [(format str arg ...) + (string? (syntax-e #'str)) + (let ([args (map minieval (syntax->list #'(arg ...)))]) + (define args* + (cond [(<= (length (filter syntax? args)) (length vars)) + (for/list ([arg args]) + (if (syntax? arg) + (begin0 (car vars) (set! vars (cdr vars))) + arg))] + [else + (let ([counter 1]) + (for/list ([arg args]) + (if (syntax? arg) + (begin0 (format "Q~a" counter) + (set! counter (add1 counter))) + arg)))])) + (apply format (syntax-e #'str) args*))] + [(quote (datum d)) + (format "expected the literal ~a" (syntax->datum #'d))] + [(quote (literal lit)) + (format "expected the literal identifier ~s" (syntax-e #'lit))] + [(quote thing) + (syntax->datum #'thing)] + [d + (let ([d (syntax->datum #'d)]) + (or (string? d) (number? d) (boolean? d))) + (syntax->datum #'d)] + [_ + x])) + (let ([ie (minieval e)]) + (if (syntax? ie) + (syntax->datum ie) + ie))) + diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 0105e234ac..16dd9ec823 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -5,6 +5,7 @@ unstable/struct "rep-data.ss" "rep.ss") + scheme/list syntax/stx "parse.ss" "runtime.ss" @@ -172,7 +173,9 @@ [(_ s) (parameterize ((current-syntax-context stx)) (with-syntax ([p (stxclass-parser-name (get-stxclass #'s))]) - #'(parser-errors p)))])) + #'(remove-duplicates + (map interpret-error-expression + (parser-errors p)))))])) (define-syntax (debug-rhs stx) (syntax-case stx () diff --git a/collects/syntax/scribblings/parse-patterns.scrbl b/collects/syntax/scribblings/parse-patterns.scrbl index 5bf8b17edc..c47fea6dd7 100644 --- a/collects/syntax/scribblings/parse-patterns.scrbl +++ b/collects/syntax/scribblings/parse-patterns.scrbl @@ -4,14 +4,22 @@ scribble/decode scribble/eval scheme/sandbox + (for-syntax scheme/base) (for-label scheme/base scheme/contract - syntax/parse + (rename-in syntax/parse [...+ DOTSPLUS]) syntax/kerncase)) -@(define ellipses @scheme[...]) +@(define-syntax-rule (define-dotsplus-names dotsplus def-dotsplus) + (begin (require (for-label (only-in syntax/parse ...+))) + (define dotsplus (scheme ...+)) + (define def-dotsplus (defhere ...+)))) +@(define-dotsplus-names dotsplus def-dotsplus) + @(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t)) +@(define ellipses @scheme[...]) + @(define Spattern "single-term pattern") @(define Lpattern "list pattern") @(define Hpattern "head pattern") @@ -84,7 +92,7 @@ When a special form in this manual refers to @svar[syntax-pattern] means specifically @tech{@Spattern}. @schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~datum - ~describe ~seq ~optional ~rep ~once + ~describe ~seq ~optional ~rep ~once ~between ~! ~bind ~fail ~parse) [S-pattern pvar-id @@ -98,7 +106,7 @@ means specifically @tech{@Spattern}. (H-pattern . S-pattern) (A-pattern . S-pattern) (EH-pattern #,ellipses . S-pattern) - (H-pattern @#,(scheme ...+) . S-pattern) + (H-pattern @#,dotsplus . S-pattern) (@#,ref[~and s] proper-S/A-pattern ...+) (@#,ref[~or s] S-pattern ...+) (~not S-pattern) @@ -113,7 +121,7 @@ means specifically @tech{@Spattern}. (A-pattern . L-pattern) (H-pattern . L-pattern) (EH-pattern #,ellipses . L-pattern) - (H-pattern @#,(scheme ...+) . L-pattern) + (H-pattern @#,dotsplus . L-pattern) (~rest L-pattern)] [H-pattern pvar-id:splicing-syntax-class-id @@ -413,14 +421,14 @@ the whole sequence pattern. See @tech{@EHpatterns} for more information. } -@specsubform[(H-pattern @#,defhere[...+] . S-pattern)]{ +@specsubform[(H-pattern @#,def-dotsplus . S-pattern)]{ Like an ellipses (@ellipses) pattern, but requires at one occurrence of the head pattern to be present. That is, the following patterns are equivalent: @itemize[ -@item[@scheme[(H ...+ . S)]] +@item[@scheme[(H @#,dotsplus . S)]] @item[@scheme[((~between H 1 +inf.0) ... . S)]] ] diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index 8ca55f2a37..25a1139d22 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -6,7 +6,7 @@ scheme/sandbox (for-label scheme/base scheme/contract - syntax/parse + (except-in syntax/parse ...+) syntax/kerncase)) @(define ellipses @scheme[...])