add 'compose' to scheme/base; switch Help Desk to a mzscheme app

svn: r7979

collects/help/help.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require "search.ss"
-         browser/external
+         net/sendurl ; browser/external
          setup/dirs
          mzlib/cmdline)
 

collects/help/info.ss

@@ -12,5 +12,5 @@
       ("help" "servlets" "scheme" "misc")
 |#
       ))
-  (define mred-launcher-libraries '("help.ss"))
+  (define mzscheme-launcher-libraries '("help.ss"))
-  (define mred-launcher-names     '("Help Desk")))
+  (define mzscheme-launcher-names     '("Help Desk")))

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) 

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)

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))])))

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}
 

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
+         (ccompose ctxt
-                  (lambda (val)
+                   (lambda (val)
-                    (quasisyntax/loc stx (set! v #,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
+         (ccompose ctxt
-                  (lambda (val)
+                   (lambda (val)
-                    (quasisyntax/loc stx 
+                     (quasisyntax/loc stx 
-                      (if #,val
+                       (if #,val
-                          #,(anormal-term #'ce)
+                           #,(anormal-term #'ce)
-                          #,(anormal-term #'ae)))))
+                           #,(anormal-term #'ae)))))
          #'te)]
        [(quote datum)
         (ctxt stx)]
@@ -116,23 +116,23 @@
         (ctxt stx)]
        [(with-continuation-mark ke me be)
         (anormal
-         (compose ctxt
+         (ccompose ctxt
-                  (lambda (kev)
+                   (lambda (kev)
-                    (anormal 
+                     (anormal 
-                     (lambda (mev)
+                      (lambda (mev)
-                       (quasisyntax/loc stx 
+                        (quasisyntax/loc stx 
-                         (with-continuation-mark #,kev #,mev
+                          (with-continuation-mark #,kev #,mev
-                           #,(anormal-term #'be))))
+                            #,(anormal-term #'be))))
-                     #'me)))
+                      #'me)))
          #'ke)]       
        [(#%plain-app fe e ...)
         (anormal
          (lambda (val0)
            (anormal*
-            (compose ctxt
+            (ccompose ctxt
-                     (lambda (rest-vals)
+                      (lambda (rest-vals)
-                       (quasisyntax/loc stx 
+                        (quasisyntax/loc stx 
-                         (#%plain-app #,val0 #,@rest-vals))))
+                          (#%plain-app #,val0 #,@rest-vals))))
             (syntax->list #'(e ...))))
          #'fe)]
        [(#%top . v)
@@ -149,9 +149,9 @@
                  (elim-letrec-term stx))]
        [(#%expression d)
         (anormal
-         (compose ctxt
+         (ccompose ctxt
-                  (lambda (d)
+                   (lambda (d)
-                    (quasisyntax/loc stx (#%expression #,d))))
+                     (quasisyntax/loc stx (#%expression #,d))))
          #'d)]
        [_
         (raise-syntax-error 'anormal "Dropped through:" stx)])))