add 'compose' to scheme/base; switch Help Desk to a mzscheme app
svn: r7979
This commit is contained in:
Matthew Flatt
parent
a58893f4ba
commit
bd7ced966e
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "search.ss"
|
||||
browser/external
|
||||
net/sendurl ; browser/external
|
||||
setup/dirs
|
||||
mzlib/cmdline)
|
||||
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))])))
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
||||
|
|
|
|||
|
|
@ -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,7 +61,7 @@
|
|||
(#%plain-app apply values #,ref-to-save)))))))]
|
||||
[(set! v ve)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(ccompose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx (set! v #,val))))
|
||||
#'ve)]
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
(syntax/loc stx (case-lambda [formals (begin be ...)] ...)))]
|
||||
[(if te ce ae)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(ccompose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx
|
||||
(if #,val
|
||||
|
|
@ -116,7 +116,7 @@
|
|||
(ctxt stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(ccompose ctxt
|
||||
(lambda (kev)
|
||||
(anormal
|
||||
(lambda (mev)
|
||||
|
|
@ -129,7 +129,7 @@
|
|||
(anormal
|
||||
(lambda (val0)
|
||||
(anormal*
|
||||
(compose ctxt
|
||||
(ccompose ctxt
|
||||
(lambda (rest-vals)
|
||||
(quasisyntax/loc stx
|
||||
(#%plain-app #,val0 #,@rest-vals))))
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
(elim-letrec-term stx))]
|
||||
[(#%expression d)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(ccompose ctxt
|
||||
(lambda (d)
|
||||
(quasisyntax/loc stx (#%expression #,d))))
|
||||
#'d)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user