Rewrite compose' and add compose1'.
The new version fixes some problems with the previous one, most notably it can create a keyworded function when the last input is is keyworded. `compose1' is a restricted variant that requires single values in the composed pipeline -- besides being potentially faster (probably more if/when there is cross module inlining), it has a semantical justification, similar to the restricting function call arguments to return single values, with similar robustness benefits. The implementation of both is done in a generalized way, and the results can be faster for both `compose' and `compose1'. (Not by much -- 20% and 30% resp.) One thing that it could do is to reduce the resulting arity to match the last given function. I didn't do this since it adds a significant overhead to the result. (No strong opinion on doing that...)
This commit is contained in:
Eli Barzilay
parent
e80308aa15
commit
be84425bd0
|
|
@ -29,20 +29,12 @@
|
|||
|
||||
(define (negate f)
|
||||
(unless (procedure? f) (raise-type-error 'negate "procedure" f))
|
||||
(let-values ([(arity) (procedure-arity f)]
|
||||
[(required-kws accepted-kws) (procedure-keywords f)])
|
||||
(define negated ; simple version, optimize some cases
|
||||
(case arity
|
||||
[(0) (lambda () (not (f)))]
|
||||
[(1) (lambda (x) (not (f x)))]
|
||||
[(2) (lambda (x y) (not (f x y)))]
|
||||
[else (lambda xs (not (apply f xs)))]))
|
||||
(if (and (null? required-kws) (null? accepted-kws))
|
||||
negated
|
||||
;; keyworded function
|
||||
(make-keyword-procedure (lambda (kws kvs . args)
|
||||
(not (keyword-apply f kws kvs args)))
|
||||
negated))))
|
||||
(let-values ([(arity) (procedure-arity f)] [(_ kwds) (procedure-keywords f)])
|
||||
(case (and (null? kwds) arity) ; optimize some simple cases
|
||||
[(0) (lambda () (not (f)))]
|
||||
[(1) (lambda (x) (not (f x)))]
|
||||
[(2) (lambda (x y) (not (f x y)))]
|
||||
[else (compose1 not f)]))) ; keyworded or more args => just compose
|
||||
|
||||
(define (make-curry right?)
|
||||
;; The real code is here
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
|
||||
(module list "pre-base.rkt"
|
||||
|
||||
(provide foldl
|
||||
|
|
@ -27,7 +26,8 @@
|
|||
build-string
|
||||
build-list
|
||||
|
||||
compose)
|
||||
compose
|
||||
compose1)
|
||||
|
||||
(#%require (rename "sort.rkt" raw-sort sort)
|
||||
(for-syntax "stxcase-scheme.rkt")
|
||||
|
|
@ -289,7 +289,7 @@
|
|||
(if (= i n)
|
||||
str
|
||||
(begin (string-set! str i (fcn i)) (loop (add1 i)))))))
|
||||
|
||||
|
||||
(define (build-list n fcn)
|
||||
(unless (exact-nonnegative-integer? n)
|
||||
(raise-type-error 'build-list "exact-nonnegative-integer" n))
|
||||
|
|
@ -301,26 +301,101 @@
|
|||
[else (cons (fcn j)
|
||||
(recr (add1 j) (sub1 i)))])))
|
||||
|
||||
(define compose
|
||||
(case-lambda
|
||||
[(f) (if (procedure? f)
|
||||
f
|
||||
(raise-type-error 'compose "procedure" f))]
|
||||
[(f g)
|
||||
(let ([f (compose f)]
|
||||
[g (compose g)])
|
||||
(if (eqv? 1 (procedure-arity f)) ; optimize: don't use call-w-values
|
||||
(if (eqv? 1 (procedure-arity g)) ; optimize: single arity everywhere
|
||||
(lambda (x) (f (g x)))
|
||||
(lambda args (f (apply g args))))
|
||||
(if (eqv? 1 (procedure-arity g)) ; optimize: single input
|
||||
(lambda (a)
|
||||
(call-with-values (lambda () (g a)) f))
|
||||
(lambda args
|
||||
(call-with-values (lambda () (apply g args)) f)))))]
|
||||
[() values]
|
||||
[(f . more)
|
||||
(if (procedure? f)
|
||||
(let ([m (apply compose more)])
|
||||
(compose f m))
|
||||
(compose f))])))
|
||||
(define-values [compose1 compose]
|
||||
(let ()
|
||||
(define-syntax-rule (app1 E1 E2) (E1 E2))
|
||||
(define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))
|
||||
(define-syntax-rule (mk-simple-compose app)
|
||||
(lambda (f g)
|
||||
(let*-values
|
||||
([(arity) (procedure-arity g)]
|
||||
[(required-kwds allowed-kwds) (procedure-keywords g)]
|
||||
[(composed)
|
||||
;; FIXME: would be nice to use `procedure-reduce-arity' and
|
||||
;; `procedure-reduce-keyword-arity' in the places marked below,
|
||||
;; but they currently add a significant overhead.
|
||||
(if (eq? 1 arity)
|
||||
(lambda (x) (app f (g x)))
|
||||
(case-lambda ; <--- here
|
||||
[(x) (app f (g x))]
|
||||
[(x y) (app f (g x y))]
|
||||
[args (app f (apply g args))]))])
|
||||
(if (null? allowed-kwds)
|
||||
composed
|
||||
(make-keyword-procedure ; <--- and here
|
||||
(lambda (kws kw-args . xs)
|
||||
(app f (keyword-apply g kws kw-args xs)))
|
||||
composed)))))
|
||||
(define-syntax-rule (can-compose* name n g f fs)
|
||||
(unless (null? (let-values ([(req _) (procedure-keywords g)]) req))
|
||||
(apply raise-type-error 'name "procedure (no required keywords)"
|
||||
n f fs)))
|
||||
(define-syntax-rule (can-compose1 name n g f fs)
|
||||
(begin (unless (procedure-arity-includes? g 1)
|
||||
(apply raise-type-error 'name "procedure (arity 1)" n f fs))
|
||||
;; need to check this too (see PR 11978)
|
||||
(can-compose* name n g f fs)))
|
||||
(define-syntax-rule (mk name app can-compose pipeline)
|
||||
(define name
|
||||
(let ([simple-compose (mk-simple-compose app)])
|
||||
(case-lambda
|
||||
[(f)
|
||||
(if (procedure? f) f (raise-type-error 'name "procedure" 0 f))]
|
||||
[(f g)
|
||||
(unless (procedure? f)
|
||||
(raise-type-error 'name "procedure" 0 f g))
|
||||
(unless (procedure? g)
|
||||
(raise-type-error 'name "procedure" 1 f g))
|
||||
(can-compose name 0 f f '())
|
||||
(simple-compose f g)]
|
||||
[() values]
|
||||
[(f0 . fs0)
|
||||
(let loop ([f f0] [fs fs0] [i 0] [rfuns '()])
|
||||
(unless (procedure? f)
|
||||
(apply raise-type-error 'name "procedure" i f0 fs0))
|
||||
(if (pair? fs)
|
||||
(begin (can-compose name i f f0 fs0)
|
||||
(loop (car fs) (cdr fs) (add1 i) (cons f rfuns)))
|
||||
(simple-compose (pipeline (car rfuns) (cdr rfuns)) f)))]))))
|
||||
(define (pipeline1 f rfuns)
|
||||
;; (very) slightly slower alternative:
|
||||
;; (if (null? rfuns)
|
||||
;; f
|
||||
;; (pipeline1 (let ([fst (car rfuns)]) (lambda (x) (fst (f x))))
|
||||
;; (cdr rfuns)))
|
||||
(lambda (x)
|
||||
(let loop ([x x] [f f] [rfuns rfuns])
|
||||
(if (null? rfuns)
|
||||
(f x)
|
||||
(loop (f x) (car rfuns) (cdr rfuns))))))
|
||||
(define (pipeline* f rfuns)
|
||||
;; use the other composition style in this case, to optimize an
|
||||
;; occasional arity-1 procedure in the pipeline
|
||||
(if (eqv? 1 (procedure-arity f))
|
||||
;; if `f' is single arity, then going in reverse they will *all* be
|
||||
;; single arities
|
||||
(let loop ([f f] [rfuns rfuns])
|
||||
(if (null? rfuns)
|
||||
f
|
||||
(loop (let ([fst (car rfuns)])
|
||||
(if (eqv? 1 (procedure-arity fst))
|
||||
(lambda (x) (fst (f x)))
|
||||
(lambda (x) (app* fst (f x)))))
|
||||
(cdr rfuns))))
|
||||
;; otherwise, going in reverse means that they're all n-ary, which
|
||||
;; means that the list of arguments will be built for each stage, so
|
||||
;; to avoid that go forward in this case
|
||||
(let ([funs (reverse (cons f rfuns))])
|
||||
(let loop ([f (car funs)] [funs (cdr funs)])
|
||||
(if (null? funs)
|
||||
f
|
||||
(loop (let ([fst (car funs)])
|
||||
(if (eqv? 1 (procedure-arity fst))
|
||||
(lambda (x) (app* f (fst x)))
|
||||
(lambda xs (app* f (apply fst xs)))))
|
||||
(cdr funs)))))))
|
||||
(mk compose1 app1 can-compose1 pipeline1)
|
||||
(mk compose app* can-compose* pipeline*)
|
||||
(values compose1 compose)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -32,20 +32,35 @@ arguments; otherwise, the @exnraise[exn:fail:contract]. The given
|
|||
(apply sort (list (list '(2) '(1)) <) #:key car)
|
||||
]}
|
||||
|
||||
@defproc[(compose [proc procedure?] ...) procedure?]{
|
||||
@deftogether[(@defproc[(compose [proc procedure?] ...) procedure?]
|
||||
@defproc[(compose1 [proc procedure?] ...) procedure?])]{
|
||||
|
||||
Returns a procedure that composes the given functions, applying the
|
||||
last @scheme[proc] first and the first @scheme[proc] last. The
|
||||
composed functions can consume and produce any number of values, as
|
||||
long as each function produces as many values as the preceding
|
||||
function consumes. When no @scheme[proc] arguments are given, the
|
||||
result is @scheme[values].
|
||||
Returns a procedure that composes the given functions, applying the last
|
||||
@scheme[proc] first and the first @scheme[proc] last. @scheme[compose]
|
||||
allows the functions to consume and produce any number of values, as
|
||||
long as each function produces as many values as the preceding function
|
||||
consumes, and @scheme[compose1] restricts the internal value passing to
|
||||
a single value. In both cases the input arity of the last function and
|
||||
the output arity of the first are unrestricted, and become the
|
||||
corresponding arity of the resulting composition (including keyword
|
||||
arguments for the input side).
|
||||
|
||||
When no @scheme[proc] arguments are given, the result is
|
||||
@scheme[values]. When exactly one is given, it is returned.
|
||||
|
||||
@mz-examples[
|
||||
((compose - sqrt) 10)
|
||||
((compose sqrt -) 10)
|
||||
((compose1 - sqrt) 10)
|
||||
((compose1 sqrt -) 10)
|
||||
((compose list split-path) (bytes->path #"/a" 'unix))
|
||||
]}
|
||||
]
|
||||
|
||||
Note that in many cases @scheme[compose1] is preferred. For example,
|
||||
using @scheme[compose] with two library functions may lead to problems
|
||||
when one function is extended to return two values, and the preceding
|
||||
one has an optional input with different semantics. In addition,
|
||||
@scheme[compose1] may create faster compositions.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(procedure-rename [proc procedure?]
|
||||
[name symbol?])
|
||||
|
|
|
|||
|
|
@ -1,31 +1,110 @@
|
|||
|
||||
(load-relative "loadtest.rktl")
|
||||
|
||||
(Section 'function)
|
||||
|
||||
(require scheme/function mzlib/etc)
|
||||
(require racket/function mzlib/etc)
|
||||
|
||||
;; stuff from scheme/base
|
||||
;; stuff from racket/base
|
||||
|
||||
(test 0 (compose add1 sub1) 0)
|
||||
(test 2 (compose add1 (lambda () 1)))
|
||||
(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4)
|
||||
(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3)
|
||||
(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2))))
|
||||
(test 'ok (compose (lambda () 'ok) (lambda () (values))))
|
||||
(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5)
|
||||
(test 0 (compose) 0)
|
||||
(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1)))
|
||||
|
||||
(err/rt-test (compose 5))
|
||||
(err/rt-test (compose add1 sub1 5))
|
||||
(err/rt-test (compose add1 5 sub1))
|
||||
(err/rt-test (compose 5 add1 sub1))
|
||||
(err/rt-test ((compose add1 (lambda () (values 1 2)))) exn:application:arity?)
|
||||
(err/rt-test ((compose add1 sub1)) exn:application:arity?)
|
||||
(err/rt-test ((compose (lambda () 1) add1) 8) exn:application:arity?)
|
||||
|
||||
(arity-test compose 0 -1)
|
||||
(let ([C #f])
|
||||
(define-syntax-rule (def-both [name* name] ...)
|
||||
(begin (define-syntax-rule (name* x (... ...))
|
||||
(begin (set! C compose1) (name x (... ...))
|
||||
(set! C compose) (name x (... ...))
|
||||
(set! C #f)))
|
||||
...))
|
||||
(def-both [test* test] [err/rt-test* err/rt-test] [test-values* test-values])
|
||||
;; Simple cases
|
||||
(test* values C)
|
||||
(test* car C car)
|
||||
(test* sin C sin)
|
||||
(err/rt-test* (C 1))
|
||||
;; Binary cases
|
||||
(test* 123 (C add1 sub1) 123)
|
||||
(test* 'composed object-name (C add1 sub1))
|
||||
(define (f:1/2 x [y 1]) (+ (* 10 x) y))
|
||||
(test* 52 (C add1 f:1/2) 5)
|
||||
(test* 16 (C add1 f:1/2) 1 5)
|
||||
(test 21 (compose f:1/2 quotient/remainder) 7 3)
|
||||
(let ([foo (compose1 f:1/2 quotient/remainder)]) (err/rt-test (foo 7 3)))
|
||||
(test* 61 (C f:1/2 +) 1 2 3)
|
||||
(define (f:kwd x #:y y #:z [z 0]) (list x y z))
|
||||
(test* '((1 2 3)) (C list f:kwd) 1 #:z 3 #:y 2)
|
||||
(test* '((1 2 0)) (C list f:kwd) 1 #:y 2)
|
||||
(err/rt-test* ((C list f:kwd) 1))
|
||||
(err/rt-test* (C 1 +))
|
||||
(err/rt-test* (C + 1))
|
||||
(err/rt-test* (C (lambda (#:x x) x) +))
|
||||
(err/rt-test* (C (lambda (x #:y y) x) +))
|
||||
(test* 3 (C length list) 1 2 3)
|
||||
(test* 2 (C length list) 1 2)
|
||||
(test* 1 (C length list) 1)
|
||||
(test* 0 (C length list))
|
||||
(err/rt-test (compose1 (lambda (x y) x) +))
|
||||
(let ([foo (compose (lambda (x y) x) +)]) ; no error here...
|
||||
(err/rt-test (foo 1))) ; ...only when running it
|
||||
;; More than two
|
||||
(err/rt-test* (C 1 add1 add1))
|
||||
(err/rt-test* (C add1 1 add1))
|
||||
(err/rt-test* (C add1 add1 1))
|
||||
(test* 4 (C add1 add1 add1) 1)
|
||||
(test* 4 (C + add1 add1 add1) 1)
|
||||
(test* 4 (C add1 + add1 add1) 1)
|
||||
(test* 4 (C add1 add1 + add1) 1)
|
||||
(test* 4 (C add1 add1 add1 +) 1)
|
||||
(test* 9 (C add1 add1 add1 +) 1 2 3)
|
||||
(err/rt-test* (C add1 (lambda (x #:y y) x) add1 add1))
|
||||
(err/rt-test (compose1 add1 (lambda (x y) x) add1 add1))
|
||||
(test #t procedure? (compose add1 (lambda (x y) x) add1 add1))
|
||||
(define (+-1 x) (values (add1 x) (sub1 x)))
|
||||
(test* #t procedure? (C list +-1 car list add1))
|
||||
(test '(7 5) (compose list +-1 car list add1) 5)
|
||||
(err/rt-test ((compose1 list +-1 car list add1) 5))
|
||||
(test* 10 (C car list sub1 car list add1) 10) ; fwd pipeline
|
||||
(test* 10 (C car list sub1 car list (lambda (x) x) add1) 10) ; rev pipeline
|
||||
;; any input arity on the RHS
|
||||
(test* 4 (C add1 add1 add1 (lambda () 1)))
|
||||
(test* 3 (C add1 add1 (lambda () 1)))
|
||||
(test* 2 (C add1 (lambda () 1)))
|
||||
(test* 1 (C (lambda () 1)))
|
||||
(test* '(1 2 3) (C car list list) 1 2 3)
|
||||
(test* '(1 2) (C car list list) 1 2)
|
||||
(test* '(1) (C car list list) 1)
|
||||
(test* '() (C car list list))
|
||||
(test* '(1 2 3) (C car list f:kwd) 1 #:z 3 #:y 2)
|
||||
(test* '(1 2 0) (C car list f:kwd) 1 #:y 2)
|
||||
;; any output arity on the LHS
|
||||
(test-values* '(2 0) (lambda () ((C +-1 add1) 0)))
|
||||
(test-values* '(3 1) (lambda () ((C +-1 add1 add1) 0)))
|
||||
(test-values* '() (lambda () ((C (lambda (_) (values)) add1) 0)))
|
||||
(test-values* '() (lambda () ((C (lambda (_) (values)) add1 add1) 0)))
|
||||
;; some older `compose' tests (a bit extended)
|
||||
(test -1 (compose (lambda (a b) (+ a b))
|
||||
(lambda (x y) (values (- y) x)))
|
||||
2 3)
|
||||
(test -1 (compose (lambda (a b) (+ a b))
|
||||
(lambda (x y) (values (- y) x))
|
||||
(lambda (x y) (values x y)))
|
||||
2 3)
|
||||
(test -1 (compose (lambda (a b) (+ a b))
|
||||
(lambda (x y) (values (- y) x))
|
||||
values)
|
||||
2 3)
|
||||
(test -1 (compose (lambda (a b) (+ a b))
|
||||
values
|
||||
(lambda (x y) (values (- y) x))
|
||||
values)
|
||||
2 3)
|
||||
(test 'hi (compose (case-lambda [(x) 'bye] [(y z) 'hi])
|
||||
(lambda () (values 1 2))))
|
||||
(test 'hi (compose (case-lambda [(x) 'bye] [(y z) 'hi])
|
||||
values
|
||||
(lambda () (values 1 2))))
|
||||
(err/rt-test* ((C add1 (lambda () (values 1 2)))) exn:fail:contract:arity?)
|
||||
(err/rt-test* ((C add1 sub1)) exn:fail:contract:arity?)
|
||||
(err/rt-test ((compose (lambda () 1) add1) 8) exn:fail:contract:arity?)
|
||||
(arity-test compose1 0 -1)
|
||||
(arity-test compose 0 -1))
|
||||
|
||||
;; ---------- rec (from mzlib/etc) ----------
|
||||
(let ()
|
||||
|
|
@ -47,6 +126,8 @@
|
|||
(let ()
|
||||
(test 'foo identity 'foo)
|
||||
(test 1 identity 1)
|
||||
(define x (gensym))
|
||||
(test x identity x)
|
||||
(err/rt-test (identity 1 2))
|
||||
(err/rt-test (identity)))
|
||||
|
||||
|
|
@ -71,18 +152,26 @@
|
|||
|
||||
;; ---------- negate ----------
|
||||
(let ()
|
||||
(define *not (negate not))
|
||||
(define *void (negate void))
|
||||
(define *< (negate <))
|
||||
(define *not (negate not))
|
||||
(test #t *not #t)
|
||||
(test #f *not #f)
|
||||
(test #t *not 12)
|
||||
(define *void (negate void))
|
||||
(test #f *void)
|
||||
(define *< (negate <))
|
||||
(test #t *< 12 3)
|
||||
(test #t *< 12 12)
|
||||
(test #f *< 11 12)
|
||||
(test #t *< 14 13 12 11)
|
||||
(test #f *< 11 12 13 14))
|
||||
(test #f *< 11 12 13 14)
|
||||
(define (bigger? n #:than [than 0]) (> n than))
|
||||
(define smaller? (negate bigger?))
|
||||
(test #t smaller? -5)
|
||||
(test #f smaller? 5)
|
||||
(test #t smaller? 5 #:than 10)
|
||||
(test #f smaller? 15 #:than 10)
|
||||
(test #t smaller? #:than 10 5)
|
||||
(test #f smaller? #:than 10 15))
|
||||
|
||||
;; ---------- curry/r ----------
|
||||
(let ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user