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

fix mandatory-after-optional checking

Browse Source 
Also fix tests for attribute change.
This commit is contained in:
Ryan Culpepper 2015-02-22 21:49:22 -05:00
parent 2a583988cb
commit 80e4894597
2 changed files with 87 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
pkgs/racket-test/tests/stxparse/function-header.rkt
View File

@ -1,80 +1,90 @@
#lang racket
#lang racket/base
(require syntax/parse
syntax/parse/lib/function-header
rackunit)
rackunit
"setup.rkt")
(define-binary-check (syntax-check-equal? actual expected)
(check-equal? (syntax->datum actual)
(syntax->datum expected)))
(syntax-check-equal?
(test-case "basic"
(syntax-parse #'(b)
[(a:arg) #'t])
#'t)
[(a:formal)
(s= t 't)]))
(syntax-check-equal?
(test-case "formal: id"
(syntax-parse #'(b)
[(a:arg) #'(a.name a.kw a.default)])
#'(b #f #f))
[(a:formal)
(s= a.name 'b)
(a= a.kw #f)
(a= a.default #f)]))
(syntax-check-equal?
(test-case "formal: kw arg"
(syntax-parse #'(#:keyword argument)
[(a:arg) #'(a.name a.kw a.default)])
#'(argument #:keyword #f))
[(a:formal)
(s= a.name 'argument)
(s= a.kw '#:keyword)
(a= a.default #f)]))
(syntax-check-equal?
(test-case "formal: kw arg w/ default"
(syntax-parse #'(#:keyword [optional argument])
[(a:arg) #'(a.name a.kw a.default)])
#'(optional #:keyword argument))
[(a:formal)
(s= a.name 'optional)
(s= a.kw '#:keyword)
(s= a.default 'argument)]))
(syntax-check-equal?
(test-case "formal: plain arg w/ default"
(syntax-parse #'([optional argument])
[(a:arg) #'(a.name a.kw a.default)])
#'(optional #f argument))
[(a:formal)
(s= a.name 'optional)
(a= a.kw #f)
(s= a.default 'argument)]))
(syntax-check-equal?
(syntax-parse #'(a b)
[(a:arg) #'f]
[_ #'t])
#'t)
(test-case "bad formal: two args"
(check-equal?
(syntax-parse #'(a b)
[(a:formal) 'ok]
[_ 'bad])
'bad))
(syntax-check-equal?
(syntax-parse #'(#:keyword)
[(a:arg) #'f]
[_ #'t])
#'t)
(test-case "bad formal: keyword"
(check-equal?
(syntax-parse #'(#:keyword)
[(a:formal) 'ok]
[_ 'bad])
'bad))
(syntax-check-equal?
(test-case "formals: simple"
(syntax-parse #'(a b c)
[a:args #'(a a.params)])
#'((a b c) (a b c)))
[a:formals
(s= a '(a b c))
(s= a.params '(a b c))]))
(syntax-check-equal?
(syntax-parse #'(a #:keyword arg #:optional [keyword arg] . rest)
[a:args #'(a a.params)])
#'((a #:keyword arg #:optional [keyword arg] . rest)
(a arg keyword rest)))
(test-case "formals: mixed"
(syntax-parse #'(a #:keyword arg #:optional [keyword arg] . rest)
[a:formals
(s= a '(a #:keyword arg #:optional [keyword arg] . rest))
(s= a.params '(a arg keyword rest))]))
(syntax-check-equal?
(syntax-parse #'([optional before] required)
[a:args #'f]
[_ #'t])
#'t)
(test-case "bad formals: mandatory after optional"
(check-equal?
(syntax-parse #'([optional before] required)
[a:formals 'ok]
[_ 'bad])
'bad))
(syntax-check-equal?
(test-case "formals: optional before rest"
(syntax-parse #'(a [optional arg] . rest)
[a:args #'(a a.params)])
#'((a [optional arg] . rest)
(a optional rest)))
[a:formals
(s= a '(a [optional arg] . rest))
(s= a.params '(a optional rest))]))
(syntax-check-equal?
(test-case "function header: simple"
(syntax-parse #'(f a b c)
[a:function-header #'(a a.params)])
#'((f a b c) (a b c)))
[a:function-header
(s= a '(f a b c ))
(s= a.params '(a b c))]))
(syntax-check-equal?
(test-case "function header: curried"
(syntax-parse #'((f doing) currying)
[a:function-header #'(a a.params)])
#'(((f doing) currying)
(doing currying)))
[a:function-header
(s= a '((f doing) currying))
(s= a.params '(doing currying))]))

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

@ -24,7 +24,7 @@
(syntax-e y)))))
"duplicate keyword for argument"
#:fail-when (invalid-option-placement
(map list (attribute arg.name) (attribute arg.default)))
(attribute arg.name) (attribute arg.default))
"default-value expression missing")
(pattern (arg:formal ... . rest:id)
#:attr params #'(arg.name ... rest)
@ -36,7 +36,7 @@
(syntax-e y)))))
"duplicate keyword for argument"
#:fail-when (invalid-option-placement
(map list (attribute arg.name) (attribute arg.default)))
(attribute arg.name) (attribute arg.default))
"default-value expression missing"))
(define-splicing-syntax-class formal
@ -50,18 +50,26 @@
#:attr default #f)
(pattern (~seq kw:keyword [name:id default])))
(define (invalid-option-placement optional-list)
(define iop
(for/fold ([status 'required])
([i optional-list]
#:break (syntax? status))
(cond [(eq? status 'required)
(cond [(not i) 'optional]
[else 'required])]
[else
(cond [(not i) 'optional]
[else (car i)])])))
(if (syntax? iop) iop #f))
;; invalid-option-placement : (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
;; Finds first name w/o corresponding default.
(define (find-mandatory names defaults)
(for/first ([name (in-list names)]
[default (in-list defaults)]
#:when (not default))
name))
;; Skip through mandatory args until first optional found, then search
;; for another mandatory.
(let loop ([names names] [defaults defaults])
(cond [(or (null? names) (null? defaults))
#f]
[(eq? (car defaults) #f) ;; mandatory
(loop (cdr names) (cdr defaults))]
[else ;; found optional
(find-mandatory (cdr names) (cdr defaults))])))
;; Copied from unstable/list
;; check-duplicate : (listof X)