From bd7ced966ed54fedd5608a68ef8ec212a913e30d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 12 Dec 2007 22:17:09 +0000 Subject: [PATCH] add 'compose' to scheme/base; switch Help Desk to a mzscheme app svn: r7979 --- collects/help/help.ss | 2 +- collects/help/info.ss | 4 +- collects/help/search.ss | 4 +- collects/mzlib/etc.ss | 26 +-------- collects/scheme/private/list.ss | 33 +++++++++++- .../scribblings/reference/procedures.scrbl | 14 +++++ collects/web-server/lang/anormal.ss | 54 +++++++++---------- 7 files changed, 78 insertions(+), 59 deletions(-) diff --git a/collects/help/help.ss b/collects/help/help.ss index 7a252e7285..4008939b2c 100644 --- a/collects/help/help.ss +++ b/collects/help/help.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "search.ss" - browser/external + net/sendurl ; browser/external setup/dirs mzlib/cmdline) diff --git a/collects/help/info.ss b/collects/help/info.ss index 915a6c004f..dfd9043aea 100644 --- a/collects/help/info.ss +++ b/collects/help/info.ss @@ -12,5 +12,5 @@ ("help" "servlets" "scheme" "misc") |# )) - (define mred-launcher-libraries '("help.ss")) - (define mred-launcher-names '("Help Desk"))) + (define mzscheme-launcher-libraries '("help.ss")) + (define mzscheme-launcher-names '("Help Desk"))) diff --git a/collects/help/search.ss b/collects/help/search.ss index bc39a07047..8dc5c00213 100644 --- a/collects/help/search.ss +++ b/collects/help/search.ss @@ -7,7 +7,7 @@ scribble/basic scribble/manual (prefix-in scheme: scribble/scheme) - browser/external + net/sendurl ; browser/external mzlib/contract) (provide/contract @@ -84,8 +84,6 @@ (send-url (format "file://~a" (path->string file))) (void)))) -(define ((compose f g) x) (f (g x))) - ;; has-match : (listof regexp) -> entry -> boolean (define ((has-match search-regexps) entry) (ormap (λ (str) diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 7b15358b40..23d656c3bc 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -5,7 +5,8 @@ (only scheme/base build-string build-list - build-vector) + build-vector + compose) "kw.ss") (require-for-syntax (lib "kerncase.ss" "syntax") @@ -53,29 +54,6 @@ (define identity (lambda (x) x)) - (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)))))] - [(f . more) - (let ([m (apply compose more)]) - (compose f m))])) - (define (loop-until start done? next body) (let loop ([i start]) (unless (done? i) diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index 945c5830bf..1427379397 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -21,7 +21,9 @@ build-vector build-string - build-list) + build-list + + compose) ;; used by sort-internal; note that a and b are reversed, to we invert `less?' ;; test @@ -317,4 +319,31 @@ (if (= i n) (reverse a) (loop (add1 i) - (cons (fcn i) a))))))) + (cons (fcn i) a)))))) + + (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)))))] + [(f . more) + (if (procedure? f) + (let ([m (apply compose more)]) + (compose f m)) + (compose f))]))) diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index 7964a9e8b1..e175b6881e 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -24,6 +24,20 @@ is called in tail position with respect to the @scheme[apply] call. (apply + '()) ]} +@defproc[(compose [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. + +@examples[ +((compose - sqrt) 10) +((compose sqrt -) 10) +((compose list split-path) (bytes->path #"/a" 'unix)) +]} + @; ---------------------------------------- @section{Keywords and Arity} diff --git a/collects/web-server/lang/anormal.ss b/collects/web-server/lang/anormal.ss index fce0e4f371..2a65c03302 100644 --- a/collects/web-server/lang/anormal.ss +++ b/collects/web-server/lang/anormal.ss @@ -11,15 +11,15 @@ ;; a context is either ;; frame -;; (compose context frame) +;; (ccompose context frame) ;; a frame is either ;; w -> target-redex ;; (listof w) -> target-redex -;; compose: (w -> target-expr) (alpha -> target-redex) -> (alpha -> target-expr) +;; ccompose: (w -> target-expr) (alpha -> target-redex) -> (alpha -> target-expr) ;; compose a context with a frame -(define (compose ctxt frame) +(define (ccompose ctxt frame) (if (eq? ctxt id) frame (lambda (val) @@ -61,9 +61,9 @@ (#%plain-app apply values #,ref-to-save)))))))] [(set! v ve) (anormal - (compose ctxt - (lambda (val) - (quasisyntax/loc stx (set! v #,val)))) + (ccompose ctxt + (lambda (val) + (quasisyntax/loc stx (set! v #,val)))) #'ve)] [(let-values () be) (anormal ctxt (syntax/loc stx be))] @@ -103,12 +103,12 @@ (syntax/loc stx (case-lambda [formals (begin be ...)] ...)))] [(if te ce ae) (anormal - (compose ctxt - (lambda (val) - (quasisyntax/loc stx - (if #,val - #,(anormal-term #'ce) - #,(anormal-term #'ae))))) + (ccompose ctxt + (lambda (val) + (quasisyntax/loc stx + (if #,val + #,(anormal-term #'ce) + #,(anormal-term #'ae))))) #'te)] [(quote datum) (ctxt stx)] @@ -116,23 +116,23 @@ (ctxt stx)] [(with-continuation-mark ke me be) (anormal - (compose ctxt - (lambda (kev) - (anormal - (lambda (mev) - (quasisyntax/loc stx - (with-continuation-mark #,kev #,mev - #,(anormal-term #'be)))) - #'me))) + (ccompose ctxt + (lambda (kev) + (anormal + (lambda (mev) + (quasisyntax/loc stx + (with-continuation-mark #,kev #,mev + #,(anormal-term #'be)))) + #'me))) #'ke)] [(#%plain-app fe e ...) (anormal (lambda (val0) (anormal* - (compose ctxt - (lambda (rest-vals) - (quasisyntax/loc stx - (#%plain-app #,val0 #,@rest-vals)))) + (ccompose ctxt + (lambda (rest-vals) + (quasisyntax/loc stx + (#%plain-app #,val0 #,@rest-vals)))) (syntax->list #'(e ...)))) #'fe)] [(#%top . v) @@ -149,9 +149,9 @@ (elim-letrec-term stx))] [(#%expression d) (anormal - (compose ctxt - (lambda (d) - (quasisyntax/loc stx (#%expression #,d)))) + (ccompose ctxt + (lambda (d) + (quasisyntax/loc stx (#%expression #,d)))) #'d)] [_ (raise-syntax-error 'anormal "Dropped through:" stx)])))