partial.rkt (4153B)
1 #lang racket/base 2 3 (provide partial 4 app 5 ) 6 7 (require racket/list 8 "arity+keywords.rkt" 9 "keyword-app.rkt" 10 ) 11 (module+ test 12 (require rackunit)) 13 14 ;; based on partial from rackjure: 15 ;; https://github.com/greghendershott/rackjure/blob/master/rackjure/utils.rkt 16 ;; http://pkg-build.racket-lang.org/doc/rackjure/index.html#%28def._%28%28lib._rackjure%2Futils..rkt%29._partial%29%29 17 18 (define (kw-proc name arity+kws proc) 19 (procedure-reduce-arity+keywords 20 (procedure-rename (make-keyword-procedure proc) name) 21 arity+kws)) 22 23 (define-syntax-rule (define-kw-proc name arity+kws clause ...) 24 (define name (kw-proc 'name arity+kws (case-lambda clause ...)))) 25 26 (define (double-keyword-apply f kws-1 kw-args-1 kws-2 kw-args-2 rest-args) 27 (keyword-app keyword-apply kws-1 kw-args-1 28 f kws-2 kw-args-2 29 rest-args)) 30 31 (define-kw-proc partial (arity+keywords (arity-at-least 0) '() #f) 32 [(kws-1 kw-args-1 f . args-1) 33 (define f.arity+kws 34 (procedure-arity+keywords f)) 35 (define arity+kws 36 (arity+keywords-subtract f.arity+kws (length args-1) kws-1)) 37 (cond [(and (empty? kws-1) (empty? kw-args-1) (empty? args-1)) f] 38 [(empty? (arity+keywords-arity arity+kws)) 39 (raise-too-many-partial-arguments-error f kws-1 kw-args-1 args-1)] 40 [else 41 (define-kw-proc partial-f arity+kws 42 [(kws-2 kw-args-2 . args-2) 43 (double-keyword-apply f kws-1 kw-args-1 kws-2 kw-args-2 44 (append args-1 args-2))]) 45 partial-f])] 46 [(kws-1 kw-args-1) 47 (keyword-app partial kws-1 kw-args-1 app)]) 48 49 (define (raise-too-many-partial-arguments-error f kws-1 kw-args-1 args-1) 50 (error 'partial 51 (string-append "too many arguments" "\n" 52 " function: ~v" "\n" 53 " partial arguments: ~a") 54 f 55 (kw-args->string kws-1 kw-args-1 args-1))) 56 57 (define (kw-args->string kws kw-args rest-args) 58 (define (string-append* . args) 59 (apply string-append (flatten args))) 60 (string-append* 61 (for/list ([arg (in-list rest-args)]) 62 (format "~v " arg)) 63 (for/list ([kw (in-list kws)] 64 [kw-arg (in-list kw-args)]) 65 (format "~a ~v " kw kw-arg)))) 66 67 68 (define-kw-proc app (arity+keywords (arity-at-least 1) '() #f) 69 [(kws kw-args f . args) 70 (keyword-apply f kws kw-args args)]) 71 72 73 74 (module+ test 75 ;; If we tested against the variable-arity `+` there would 76 ;; be no difference between `partial` and `curry`. 77 (define (+* x y) (+ x y)) 78 79 (check-equal? ((partial +*) 1 2) 3) 80 (check-equal? ((partial +* 1) 2) 3) 81 (check-equal? ((partial +* 1 2)) 3) 82 (check-equal? ((partial) +* 1 2) 3) 83 (check-exn (regexp (regexp-quote "too many arguments")) 84 (λ () (partial +* 1 2 3))) 85 86 ;; arity 87 (check-equal? (procedure-arity+keywords (partial +*)) (arity+keywords 2 '() '())) 88 (check-equal? (procedure-arity+keywords (partial +* 1)) (arity+keywords 1 '() '())) 89 (check-equal? (procedure-arity+keywords (partial +* 1 2)) (arity+keywords 0 '() '())) 90 91 ;; keywords 92 (test-case "partial with keywords" 93 (define (KE #:m m #:v v) 94 (* 1/2 m v v)) 95 (check-equal? ((partial KE) #:m 2 #:v 1) 1) 96 (check-equal? ((partial KE #:m 2) #:v 1) 1) 97 (check-equal? ((partial KE #:m 2 #:v 1)) 1) 98 (check-equal? ((partial) KE #:m 2 #:v 1) 1) 99 (check-equal? ((partial #:m 2) KE #:v 1) 1) 100 (check-exn (regexp (regexp-quote "too many arguments")) 101 (λ () (partial KE #:whatever "idontkare"))) 102 ;; arity 103 (check-equal? (procedure-arity+keywords (partial KE)) (arity+keywords 0 '(#:m #:v) '(#:m #:v))) 104 (check-equal? (procedure-arity+keywords (partial KE #:m 2)) (arity+keywords 0 '(#:v) '(#:v))) 105 (check-equal? (procedure-arity+keywords (partial KE #:v 1)) (arity+keywords 0 '(#:m) '(#:m))) 106 (check-equal? (procedure-arity+keywords (partial KE #:m 2 #:v 1)) (arity+keywords 0 '() '())) 107 (check-equal? (procedure-arity+keywords (partial)) (arity+keywords (arity-at-least 1) '() #f)) 108 (check-equal? (procedure-arity+keywords (partial #:m 2))(arity+keywords(arity-at-least 1)'()#f))))