kw-apply.rkt (3500B)
1 #lang racket/base 2 3 (provide apply/kw) 4 5 (require racket/match) 6 7 (module+ test 8 (require rackunit (for-syntax racket/base syntax/parse))) 9 10 (define (apply/kw f args) 11 (define-values (kws kw-args rest-args) 12 (parse-args args)) 13 (keyword-apply f kws kw-args rest-args)) 14 15 ;; parse-args : (Listof Any) -> (values (Listof Keyword) (Listof Any) (Listof Any)) 16 ;; returns 3 values 17 ;; the first value is a list of the keywords 18 ;; the second values is a list of the keyword arguments 19 ;; the third value is a list of the by-position arguments 20 (define (parse-args args) 21 (define (return #:kws kws #:kw-args kw-args #:rest-args rest-args) 22 (values kws kw-args rest-args)) 23 (define-values (kw-hash bkwds-rst) 24 (args->kw-hash+bkwds-rst args)) 25 (define kws (sort (hash-keys kw-hash) keyword<?)) 26 (define kw-args 27 (for/list ([kw (in-list kws)]) 28 (hash-ref kw-hash kw))) 29 (define rest-args (reverse bkwds-rst)) 30 (return #:kws kws 31 #:kw-args kw-args 32 #:rest-args rest-args)) 33 34 ;; args->hash+bwds-rst : (Listof Any) #:kw-hash (Hashof Keyword Any) #:bkwds-rst (Listof Any) 35 ;; -> (values (Hashof Keyword Any) (Listof Any)) 36 ;; returns 2 values 37 ;; the first value is a hash-table containing the keywords and keyword-arguments 38 ;; the second value is a backwards list of the by-position arguments 39 ;; both values are accumulated in the #:kw-hash and #:bkwds-rst arguments 40 (define (args->kw-hash+bkwds-rst args #:kw-hash [kw-hash #hash()] #:bkwds-rst [bkwds-rst '()]) 41 (define (return #:kw-hash [kw-hash kw-hash] #:bkwds-rst [bkwds-rst bkwds-rst]) 42 (values kw-hash bkwds-rst)) 43 (match args 44 [(list) 45 (return)] 46 [(list arg) 47 (return #:bkwds-rst (cons arg bkwds-rst))] 48 [(list (? keyword? kw) kw-arg) 49 (return #:kw-hash (hash-set kw-hash kw kw-arg))] 50 [(list-rest (and arg (not (? keyword?))) rest) 51 (args->kw-hash+bkwds-rst rest 52 #:kw-hash kw-hash 53 #:bkwds-rst (cons arg bkwds-rst))] 54 [(list-rest (? keyword? kw) kw-arg rest) 55 (args->kw-hash+bkwds-rst rest 56 #:kw-hash (hash-set kw-hash kw kw-arg) 57 #:bkwds-rst bkwds-rst)])) 58 59 60 61 (module+ test 62 (define-syntax-rule (values->list expr) 63 (call-with-values (λ () expr) list)) 64 (define-syntax check-match/values 65 (lambda (stx) 66 (syntax-parse stx #:literals (values) 67 [(check-match/values expr (values pat ...)) 68 (syntax/loc stx 69 (check-match (values->list expr) (list pat ...)))]))) 70 (test-case "apply/kw" 71 (define proc (make-keyword-procedure list)) 72 (check-equal? (apply/kw proc '(1 2 3)) '(() () 1 2 3)) 73 (check-equal? (apply/kw proc '(1 #:kw2 kw-arg2 2 5 #:kw1 kw-arg1 3)) 74 '((#:kw1 #:kw2) (kw-arg1 kw-arg2) 1 2 5 3))) 75 (test-case "parse-args" 76 (check-match/values (parse-args '()) 77 (values '() '() '())) 78 (check-match/values (parse-args '(0)) 79 (values '() '() '(0))) 80 (check-match/values (parse-args '(#:kw "kw-arg")) 81 (values '(#:kw) '("kw-arg") '())) 82 (check-match/values (parse-args '(0 1 #:kw-1 "kw-arg-1" 2 #:kw-2 "kw-arg-2" 3 4)) 83 (values '(#:kw-1 #:kw-2) '("kw-arg-1" "kw-arg-2") '(0 1 2 3 4))) 84 (check-match/values (parse-args '(0 1 2 #:kw-2 "kw-arg-2" 3 4 #:kw-1 "kw-arg-1")) 85 (values '(#:kw-1 #:kw-2) '("kw-arg-1" "kw-arg-2") '(0 1 2 3 4)))) 86 )