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

Skip keywords in invalid-option-placement (#3621)

Browse Source 
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
This commit is contained in:
xxyzz 2021-03-06 07:55:52 +08:00 committed by GitHub
parent 1484b35516
commit d03456b55e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 79 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
View File

@ -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)])
]
]
@defstxclass[formals-no-rest #:splicing]{
Like @racket[formals] but without dotted-tail identifier.
@defattribute[params syntax?]{
The list of parameters.
}
}

41
pkgs/racket-test/tests/stxparse/test.rkt
View File

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

101
racket/collects/syntax/parse/lib/function-header.rkt
View File

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