no need for the commented subtract-out, since it is swalloed by except-out now
svn: r9016
This commit is contained in:
parent
3a763f3bcc
commit
d0b86a31d1
32
collects/scheme/function.ss
Normal file
32
collects/scheme/function.ss
Normal file
|
@ -0,0 +1,32 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
|
(provide negate curry)
|
||||||
|
|
||||||
|
(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
|
||||||
|
(if (and (null? required-kws) (null? accepted-kws))
|
||||||
|
;; simple function
|
||||||
|
(if (equal? arity 1) ; optimize common case
|
||||||
|
(lambda (x) (not (f x)))
|
||||||
|
(lambda xs (not (apply f xs))))
|
||||||
|
;; keyworded function
|
||||||
|
(make-keyword-procedure
|
||||||
|
(lambda (kws kw-args . rest)
|
||||||
|
(not (keyword-apply f kws kw-args rest))))))
|
||||||
|
negated))
|
||||||
|
|
||||||
|
(define (curry f . args)
|
||||||
|
(unless (procedure? f) (raise-type-error 'curry "procedure" f))
|
||||||
|
(let loop ([args args])
|
||||||
|
(define curry
|
||||||
|
(if (null? args) ; always at least one step
|
||||||
|
(lambda more (loop more))
|
||||||
|
(lambda more
|
||||||
|
(let ([args (append args more)])
|
||||||
|
(if (procedure-arity-includes? f (length args))
|
||||||
|
(apply f args)
|
||||||
|
(loop args))))))
|
||||||
|
curry))
|
|
@ -13,18 +13,3 @@
|
||||||
(filter (lambda (e)
|
(filter (lambda (e)
|
||||||
(regexp-match? rx (symbol->string (export-out-sym e))))
|
(regexp-match? rx (symbol->string (export-out-sym e))))
|
||||||
(expand-export #'spec modes)))]))))
|
(expand-export #'spec modes)))]))))
|
||||||
|
|
||||||
#| Cute, and symmetric to subtract-in, but useless
|
|
||||||
(provide subtract-out)
|
|
||||||
(define-syntax subtract-out
|
|
||||||
(make-provide-transformer
|
|
||||||
(lambda (stx modes)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ spec specs ...)
|
|
||||||
(let* ([subs (map (lambda (spec) (expand-export spec modes))
|
|
||||||
(syntax->list #'(specs ...)))]
|
|
||||||
[subs (map (lambda (i) (syntax-e (export-out-sym i)))
|
|
||||||
(apply append subs))])
|
|
||||||
(filter (lambda (i) (not (memq (export-out-sym i) subs)))
|
|
||||||
(expand-export #'spec modes)))]))))
|
|
||||||
|#
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user