function-header.rkt (4763B)
1 #lang racket/base 2 3 (require "../../parse.rkt" 4 "../experimental/template.rkt" 5 racket/dict) 6 7 (provide function-header formal formals) 8 9 (define-syntax-class function-header 10 (pattern ((~or header:function-header name:id) . args:formals) 11 #:attr params 12 (template ((?@ . (?? header.params ())) 13 . args.params)))) 14 15 (define-syntax-class formals 16 #:attributes (params) 17 (pattern (arg:formal ...) 18 #:attr params #'(arg.name ...) 19 #:fail-when (check-duplicate-identifier (syntax->list #'params)) 20 "duplicate argument name" 21 #:fail-when (check-duplicate (attribute arg.kw) 22 #:same? (λ (x y) 23 (and x y (equal? (syntax-e x) 24 (syntax-e y))))) 25 "duplicate keyword for argument" 26 #:fail-when (invalid-option-placement 27 (attribute arg.name) (attribute arg.default)) 28 "default-value expression missing") 29 (pattern (arg:formal ... . rest:id) 30 #:attr params #'(arg.name ... rest) 31 #:fail-when (check-duplicate-identifier (syntax->list #'params)) 32 "duplicate argument name" 33 #:fail-when (check-duplicate (attribute arg.kw) 34 #:same? (λ (x y) 35 (and x y (equal? (syntax-e x) 36 (syntax-e y))))) 37 "duplicate keyword for argument" 38 #:fail-when (invalid-option-placement 39 (attribute arg.name) (attribute arg.default)) 40 "default-value expression missing")) 41 42 (define-splicing-syntax-class formal 43 #:attributes (name kw default) 44 (pattern name:id 45 #:attr kw #f 46 #:attr default #f) 47 (pattern [name:id default] 48 #:attr kw #f) 49 (pattern (~seq kw:keyword name:id) 50 #:attr default #f) 51 (pattern (~seq kw:keyword [name:id default]))) 52 53 ;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f 54 ;; Checks for mandatory argument after optional argument; if found, returns 55 ;; identifier of mandatory argument. 56 (define (invalid-option-placement names defaults) 57 ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f 58 ;; Finds first name w/o corresponding default. 59 (define (find-mandatory names defaults) 60 (for/first ([name (in-list names)] 61 [default (in-list defaults)] 62 #:when (not default)) 63 name)) 64 ;; Skip through mandatory args until first optional found, then search 65 ;; for another mandatory. 66 (let loop ([names names] [defaults defaults]) 67 (cond [(or (null? names) (null? defaults)) 68 #f] 69 [(eq? (car defaults) #f) ;; mandatory 70 (loop (cdr names) (cdr defaults))] 71 [else ;; found optional 72 (find-mandatory (cdr names) (cdr defaults))]))) 73 74 ;; Copied from unstable/list 75 ;; check-duplicate : (listof X) 76 ;; #:key (X -> K) 77 ;; #:same? (or/c (K K -> bool) dict?) 78 ;; -> X or #f 79 (define (check-duplicate items 80 #:key [key values] 81 #:same? [same? equal?]) 82 (cond [(procedure? same?) 83 (cond [(eq? same? equal?) 84 (check-duplicate/t items key (make-hash) #t)] 85 [(eq? same? eq?) 86 (check-duplicate/t items key (make-hasheq) #t)] 87 [(eq? same? eqv?) 88 (check-duplicate/t items key (make-hasheqv) #t)] 89 [else 90 (check-duplicate/list items key same?)])] 91 [(dict? same?) 92 (let ([dict same?]) 93 (if (dict-mutable? dict) 94 (check-duplicate/t items key dict #t) 95 (check-duplicate/t items key dict #f)))])) 96 (define (check-duplicate/t items key table mutating?) 97 (let loop ([items items] [table table]) 98 (and (pair? items) 99 (let ([key-item (key (car items))]) 100 (if (dict-ref table key-item #f) 101 (car items) 102 (loop (cdr items) (if mutating? 103 (begin (dict-set! table key-item #t) table) 104 (dict-set table key-item #t)))))))) 105 (define (check-duplicate/list items key same?) 106 (let loop ([items items] [sofar null]) 107 (and (pair? items) 108 (let ([key-item (key (car items))]) 109 (if (for/or ([prev (in-list sofar)]) 110 (same? key-item prev)) 111 (car items) 112 (loop (cdr items) (cons key-item sofar)))))))