From d03456b55e9321d491b5a936cf721466728376e2 Mon Sep 17 00:00:00 2001 From: xxyzz Date: Sat, 6 Mar 2021 07:55:52 +0800 Subject: [PATCH] Skip keywords in invalid-option-placement (#3621) Close #3603 * skip keywords in invalid-option-placement * replace check-duplicate with check-duplicates * add skip keywords test * add require and fix syntax-e error * update comment of invalid-option-placement * add mixture keywords and arguments test * forget to skip keyword in loop * and another two tests for syntax-parse * define splicing-formals-no-rest as @Metaxal suggested * add formals link * rename splicing-formals-no-rest to formals-no-rest * add attributes to formals * remove racket/dict import --- .../syntax/scribblings/parse/lib.scrbl | 9 +- pkgs/racket-test/tests/stxparse/test.rkt | 41 +++++++ .../syntax/parse/lib/function-header.rkt | 101 ++++++------------ 3 files changed, 79 insertions(+), 72 deletions(-) diff --git a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl index fff7b2d65c..def0c1a031 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl @@ -274,4 +274,11 @@ Note that the literal-set uses the names @racket[#%plain-lambda] and (~? fml.default #f))]) (syntax-parse #'(lambda (#:kw [kw 42]) kw) [(_ (fml:formal) body ...+) #'(fml fml.name fml.kw fml.default)]) -] \ No newline at end of file +] + +@defstxclass[formals-no-rest #:splicing]{ + Like @racket[formals] but without dotted-tail identifier. + @defattribute[params syntax?]{ + The list of parameters. + } +} \ No newline at end of file diff --git a/pkgs/racket-test/tests/stxparse/test.rkt b/pkgs/racket-test/tests/stxparse/test.rkt index 7590573466..07510a0ea3 100644 --- a/pkgs/racket-test/tests/stxparse/test.rkt +++ b/pkgs/racket-test/tests/stxparse/test.rkt @@ -1059,3 +1059,44 @@ (convert-compile-time-error (syntax-parse #'(1 2 'bar 4 5 'bar 'foo) [((~seq (~between x:nat 2 2) ... z) ...+ expr) (void)])) + +;; from Laurent Orseau, issue #3603 (1/2021) +(require syntax/parse/lib/function-header) +(check-equal? + (syntax->datum + (syntax-parse #'(#:a [a 1] #:b b) + [fmls:formals #'(fmls fmls.params)])) + '((#:a (a 1) #:b b) (a b))) + +(check-equal? + (syntax->datum + (syntax-parse #'(a #:b [b 1] c #:d d [e 2] #:f [f 3] [g 4] . rest) + [fmls:formals #'(fmls fmls.params)])) + '((a #:b [b 1] c #:d d [e 2] #:f [f 3] [g 4] . rest) (a b c d e f g rest))) + +(check-equal? + (syntax->datum + (syntax-parse #'(a #:b [b 1] c) + [fmls:formals #'(fmls fmls.params)])) + '((a #:b [b 1] c) (a b c))) + +(check-exn + #rx"me: default-value expression missing" + (lambda () + (syntax-parse #'(a [b 1] c) + #:context 'me + [fmls:formals #'(fmls fmls.params)]))) + +(check-exn + #rx"me: duplicate argument identifier" + (lambda () + (syntax-parse #'(a . a) + #:context 'me + [fmls:formals #'(fmls fmls.params)]))) + +(check-exn + #rx"me: duplicate argument identifier" + (lambda () + (syntax-parse #'(#:a a . a) + #:context 'me + [fmls:formals #'(fmls fmls.params)]))) diff --git a/racket/collects/syntax/parse/lib/function-header.rkt b/racket/collects/syntax/parse/lib/function-header.rkt index 2e67c1ecb7..db6e852c0b 100644 --- a/racket/collects/syntax/parse/lib/function-header.rkt +++ b/racket/collects/syntax/parse/lib/function-header.rkt @@ -1,9 +1,9 @@ #lang racket/base (require "../../parse.rkt" - racket/dict) + racket/list) -(provide function-header formal formals) +(provide function-header formal formals formals-no-rest) (define-syntax-class function-header #:attributes (name params args) @@ -11,33 +11,30 @@ #:attr params #'((~@ . (~? header.params ())) . args.params) #:attr name #'(~? header.name name*))) -(define-syntax-class formals +(define-splicing-syntax-class formals-no-rest #:attributes (params) - (pattern (arg:formal ...) + (pattern (~seq arg:formal ...) #:attr params #'(arg.name ...) #:fail-when (check-duplicate-identifier (syntax->list #'params)) "duplicate argument name" - #:fail-when (check-duplicate (attribute arg.kw) - #:same? (λ (x y) - (and x y (equal? (syntax-e x) - (syntax-e y))))) + #:fail-when (check-duplicates (attribute arg.kw) + (lambda (x y) + (and x y (equal? (syntax-e x) (syntax-e y))))) "duplicate keyword for argument" #:fail-when (invalid-option-placement - (attribute arg.name) (attribute arg.default)) - "default-value expression missing") - (pattern (arg:formal ... . rest:id) - #:attr params #'(arg.name ... rest) - #:fail-when (check-duplicate-identifier (syntax->list #'params)) - "duplicate argument name" - #:fail-when (check-duplicate (attribute arg.kw) - #:same? (λ (x y) - (and x y (equal? (syntax-e x) - (syntax-e y))))) - "duplicate keyword for argument" - #:fail-when (invalid-option-placement - (attribute arg.name) (attribute arg.default)) + (attribute arg.kw) (attribute arg.name) (attribute arg.default)) "default-value expression missing")) +(define-syntax-class formals + #:attributes (params) + (pattern (~or* (args:formals-no-rest) + (args:formals-no-rest . rest-id:id)) + #:attr params #'((~@ . args.params) (~? rest-id)) + #:fail-when (and (attribute rest-id) + (member #'rest-id (syntax->list #'args.params) bound-identifier=?) + #'rest-id) + "duplicate argument identifier")) + (define-splicing-syntax-class formal #:attributes (name kw default) (pattern name:id @@ -49,63 +46,25 @@ #:attr default #f) (pattern (~seq kw:keyword [name:id default]))) -;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; invalid-option-placement : (Listof Keyword) (Listof Id) (Listof Syntax/#f) -> Id/#f ;; Checks for mandatory argument after optional argument; if found, returns ;; identifier of mandatory argument. -(define (invalid-option-placement names defaults) - ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f +(define (invalid-option-placement kws names defaults) + ;; find-mandatory : (Listof Keyword) (Listof Id) (Listof Syntax/#f) -> Id/#f ;; Finds first name w/o corresponding default. - (define (find-mandatory names defaults) - (for/first ([name (in-list names)] + (define (find-mandatory kws names defaults) + (for/first ([kw (in-list kws)] + [name (in-list names)] [default (in-list defaults)] - #:when (not default)) + #:when (and (not kw) (not default))) name)) ;; Skip through mandatory args until first optional found, then search ;; for another mandatory. - (let loop ([names names] [defaults defaults]) + (let loop ([kws kws] [names names] [defaults defaults]) (cond [(or (null? names) (null? defaults)) #f] - [(eq? (car defaults) #f) ;; mandatory - (loop (cdr names) (cdr defaults))] + [(or (car kws) ;; keyword + (eq? (car defaults) #f)) ;; mandatory arg + (loop (cdr kws) (cdr names) (cdr defaults))] [else ;; found optional - (find-mandatory (cdr names) (cdr defaults))]))) - -;; Copied from unstable/list -;; check-duplicate : (listof X) -;; #:key (X -> K) -;; #:same? (or/c (K K -> bool) dict?) -;; -> X or #f -(define (check-duplicate items - #:key [key values] - #:same? [same? equal?]) - (cond [(procedure? same?) - (cond [(eq? same? equal?) - (check-duplicate/t items key (make-hash) #t)] - [(eq? same? eq?) - (check-duplicate/t items key (make-hasheq) #t)] - [(eq? same? eqv?) - (check-duplicate/t items key (make-hasheqv) #t)] - [else - (check-duplicate/list items key same?)])] - [(dict? same?) - (let ([dict same?]) - (if (dict-mutable? dict) - (check-duplicate/t items key dict #t) - (check-duplicate/t items key dict #f)))])) -(define (check-duplicate/t items key table mutating?) - (let loop ([items items] [table table]) - (and (pair? items) - (let ([key-item (key (car items))]) - (if (dict-ref table key-item #f) - (car items) - (loop (cdr items) (if mutating? - (begin (dict-set! table key-item #t) table) - (dict-set table key-item #t)))))))) -(define (check-duplicate/list items key same?) - (let loop ([items items] [sofar null]) - (and (pair? items) - (let ([key-item (key (car items))]) - (if (for/or ([prev (in-list sofar)]) - (same? key-item prev)) - (car items) - (loop (cdr items) (cons key-item sofar))))))) + (find-mandatory (cdr kws) (cdr names) (cdr defaults))])))