suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adapted unstable/cce/function to unstable/function.

Browse Source
This commit is contained in:
Carl Eastlund 2010-05-28 20:56:56 -04:00
parent 6f39c3fca1
commit 8d10a6343b
12 changed files with 206 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
collects/tests/unstable/function.rkt Normal file
View File

@ -0,0 +1,153 @@
#lang racket
(require rackunit rackunit/text-ui unstable/function
"helpers.rkt")
(define list/kw (make-keyword-procedure list))
(run-tests
(test-suite "function.ss"
(test-suite "Simple Functions"
(test-suite "identity"
(test-case "unique symbol"
(let* ([sym (gensym)])
(check-eq? (identity sym) sym))))
(test-suite "const"
(test-case "unique symbol"
(let* ([sym (gensym)])
(check-eq? ((const sym) 'x #:y 'z) sym))))
(test-suite "thunk"
(test-case "unique symbol"
(let* ([count 0]
[f (thunk (set! count (+ count 1)) count)])
(check = count 0)
(check = (f) 1)
(check = count 1)))))
(test-suite "Higher Order Predicates"
(test-suite "negate"
(test-case "integer?"
(check-false ((negate integer?) 5)))
(test-case "not integer?"
(check-true ((negate integer?) 1/5)))
(test-case "non-boolean"
(check-false ((negate symbol->string) 'sym)))
(test-case "binary"
(check-false ((negate +) 1 2 3))))
(test-suite "conjoin"
(test-case "no functions"
(check-true ((conjoin) 'x #:y 'z)))
(test-case "true"
(check-true ((conjoin integer? exact?) 1)))
(test-case "false"
(check-false ((conjoin integer? exact?) 1.0)))
(test-case "false"
(check-false ((conjoin integer? exact?) 0.5))))
(test-suite "disjoin"
(test-case "no functions"
(check-false ((disjoin) 'x #:y 'z)))
(test-case "true"
(check-true ((disjoin integer? exact?) 1)))
(test-case "true"
(check-true ((disjoin integer? exact?) 1/2)))
(test-case "false"
(check-false ((disjoin integer? exact?) 0.5)))))
(test-suite "Currying and (Partial) Application"
(test-suite "call"
(test-case "string-append"
(check-equal? (call string-append "a" "b" "c") "abc")))
(test-suite "papply"
(test-case "list"
(check-equal? ((papply list 1 2) 3 4) (list 1 2 3 4)))
(test-case "sort"
(check-equal?
((papply sort '((1 a) (4 d) (2 b) (3 c)) #:cache-keys? #f)
< #:key car)
'((1 a) (2 b) (3 c) (4 d)))))
(test-suite "papplyr"
(test-case "list"
(check-equal? ((papplyr list 1 2) 3 4) (list 3 4 1 2)))
(test-case "sort"
(check-equal?
((papplyr sort < #:key car)
'((1 a) (4 d) (2 b) (3 c)) #:cache-keys? #f)
'((1 a) (2 b) (3 c) (4 d)))))
(test-suite "curryn"
(test-case "1"
(check-equal? (curryn 0 list/kw 1) '(() () 1)))
(test-case "1 / 2"
(check-equal? ((curryn 1 list/kw 1) 2) '(() () 1 2)))
(test-case "1 / 2 / 3"
(check-equal? (((curryn 2 list/kw 1) 2) 3) '(() () 1 2 3)))
(test-case "1 a"
(check-equal? (curryn 0 list/kw 1 #:a "a")
'((#:a) ("a") 1)))
(test-case "1 a / 2 b"
(check-equal? ((curryn 1 list/kw 1 #:a "a") 2 #:b "b")
'((#:a #:b) ("a" "b") 1 2)))
(test-case "1 a / 2 b / 3 c"
(check-equal? (((curryn 2 list/kw 1 #:a "a") 2 #:b "b") 3 #:c "c")
'((#:a #:b #:c) ("a" "b" "c") 1 2 3))))
(test-suite "currynr"
(test-case "1"
(check-equal? (currynr 0 list/kw 1) '(() () 1)))
(test-case "1 / 2"
(check-equal? ((currynr 1 list/kw 1) 2) '(() () 2 1)))
(test-case "1 / 2 / 3"
(check-equal? (((currynr 2 list/kw 1) 2) 3) '(() () 3 2 1)))
(test-case "1 a"
(check-equal? (currynr 0 list/kw 1 #:a "a")
'((#:a) ("a") 1)))
(test-case "1 a / 2 b"
(check-equal? ((currynr 1 list/kw 1 #:a "a") 2 #:b "b")
'((#:a #:b) ("a" "b") 2 1)))
(test-case "1 a / 2 b / 3 c"
(check-equal? (((currynr 2 list/kw 1 #:a "a") 2 #:b "b") 3 #:c "c")
'((#:a #:b #:c) ("a" "b" "c") 3 2 1)))))
(test-suite "Eta Expansion"
(test-suite "eta"
(test-ok (define f (eta g))
(define g add1)
(check-equal? (f 1) 2)))
(test-suite "eta*"
(test-ok (define f (eta* g x))
(define g add1)
(check-equal? (f 1) 2))
(test-bad (define f (eta* g x))
(define g list)
(f 1 2))))
(test-suite "Parameter Arguments"
(test-suite "lambda/parameter"
(test-case "provided"
(let* ([p (make-parameter 0)])
(check = ((lambda/parameter ([x #:param p]) x) 1) 1)))
(test-case "not provided"
(let* ([p (make-parameter 0)])
(check = ((lambda/parameter ([x #:param p]) x)) 0)))
(test-case "argument order / provided"
(let* ([p (make-parameter 3)])
(check-equal? ((lambda/parameter (x [y 2] [z #:param p])
(list x y z))
4 5 6)
(list 4 5 6))))
(test-case "argument order / not provided"
(let* ([p (make-parameter 3)])
(check-equal? ((lambda/parameter (x [y 2] [z #:param p])
(list x y z))
1)
(list 1 2 3))))))))

20
collects/tests/unstable/helpers.rkt Normal file
View File

@ -0,0 +1,20 @@
#lang racket
(provide test
test-ok check-ok
test-bad check-bad)
(require rackunit racket/pretty)
(define-syntax-rule (test e ...)
(test-case (parameterize ([pretty-print-columns 50])
(pretty-format/write '(test e ...)))
e ...))
(define-syntax-rule (test-ok e ...) (test (check-ok e ...)))
(define-syntax-rule (test-bad e ...) (test (check-bad e ...)))
(define-syntax-rule (check-ok e ...) (check-not-exn (lambda () e ...)))
(define-syntax-rule (check-bad e ...) (check-exn exn:fail? (lambda () e ...)))
(define (pretty-format/write x)
(with-output-to-string
(lambda () (pretty-write x))))

2
collects/unstable/cce/match.ss
View File

@ -2,8 +2,8 @@
(require
(for-syntax scheme/match
scheme/struct-info
unstable/function
"define.ss"
"function.ss"
"syntax.ss"))
(define-syntax-rule (match? e p ...)

2
collects/unstable/cce/port.ss
View File

@ -1,6 +1,6 @@
#lang scheme
(require "function.ss" "syntax.ss" "private/define-core.ss")
(require unstable/function "syntax.ss" "private/define-core.ss")
(define-if-unbound (eprintf fmt . args)
(apply fprintf (current-error-port) fmt args))

2
collects/unstable/cce/reference/manual.scrbl
View File

@ -10,8 +10,6 @@
@table-of-contents[]
@include-section["function.scrbl"]
@include-section["values.scrbl"]
@include-section["text.scrbl"]

157
collects/unstable/cce/test/test-function.ss
View File

@ -1,157 +0,0 @@
#lang scheme
(require "checks.ss"
"../function.ss")
(provide function-suite)
(define list/kw (make-keyword-procedure list))
(define function-suite
(test-suite "function.ss"
(test-suite "Simple Functions"
(test-suite "identity"
(test-case "unique symbol"
(let* ([sym (gensym)])
(check-eq? (identity sym) sym))))
(test-suite "const"
(test-case "unique symbol"
(let* ([sym (gensym)])
(check-eq? ((const sym) 'x #:y 'z) sym))))
(test-suite "thunk"
(test-case "unique symbol"
(let* ([count 0]
[f (thunk (set! count (+ count 1)) count)])
(check = count 0)
(check = (f) 1)
(check = count 1)))))
(test-suite "Higher Order Predicates"
(test-suite "negate"
(test-case "integer?"
(check-false ((negate integer?) 5)))
(test-case "not integer?"
(check-true ((negate integer?) 1/5)))
(test-case "non-boolean"
(check-false ((negate symbol->string) 'sym)))
(test-case "binary"
(check-false ((negate +) 1 2 3))))
(test-suite "conjoin"
(test-case "no functions"
(check-true ((conjoin) 'x #:y 'z)))
(test-case "true"
(check-true ((conjoin integer? exact?) 1)))
(test-case "false"
(check-false ((conjoin integer? exact?) 1.0)))
(test-case "false"
(check-false ((conjoin integer? exact?) 0.5))))
(test-suite "disjoin"
(test-case "no functions"
(check-false ((disjoin) 'x #:y 'z)))
(test-case "true"
(check-true ((disjoin integer? exact?) 1)))
(test-case "true"
(check-true ((disjoin integer? exact?) 1/2)))
(test-case "false"
(check-false ((disjoin integer? exact?) 0.5)))))
(test-suite "Currying and (Partial) Application"
(test-suite "call"
(test-case "string-append"
(check-equal? (call string-append "a" "b" "c") "abc")))
(test-suite "papply"
(test-case "list"
(check-equal? ((papply list 1 2) 3 4) (list 1 2 3 4)))
(test-case "sort"
(check-equal?
((papply sort '((1 a) (4 d) (2 b) (3 c)) #:cache-keys? #f)
< #:key car)
'((1 a) (2 b) (3 c) (4 d)))))
(test-suite "papplyr"
(test-case "list"
(check-equal? ((papplyr list 1 2) 3 4) (list 3 4 1 2)))
(test-case "sort"
(check-equal?
((papplyr sort < #:key car)
'((1 a) (4 d) (2 b) (3 c)) #:cache-keys? #f)
'((1 a) (2 b) (3 c) (4 d)))))
(test-suite "curryn"
(test-case "1"
(check-equal? (curryn 0 list/kw 1) '(() () 1)))
(test-case "1 / 2"
(check-equal? ((curryn 1 list/kw 1) 2) '(() () 1 2)))
(test-case "1 / 2 / 3"
(check-equal? (((curryn 2 list/kw 1) 2) 3) '(() () 1 2 3)))
(test-case "1 a"
(check-equal? (curryn 0 list/kw 1 #:a "a")
'((#:a) ("a") 1)))
(test-case "1 a / 2 b"
(check-equal? ((curryn 1 list/kw 1 #:a "a") 2 #:b "b")
'((#:a #:b) ("a" "b") 1 2)))
(test-case "1 a / 2 b / 3 c"
(check-equal? (((curryn 2 list/kw 1 #:a "a") 2 #:b "b") 3 #:c "c")
'((#:a #:b #:c) ("a" "b" "c") 1 2 3))))
(test-suite "currynr"
(test-case "1"
(check-equal? (currynr 0 list/kw 1) '(() () 1)))
(test-case "1 / 2"
(check-equal? ((currynr 1 list/kw 1) 2) '(() () 2 1)))
(test-case "1 / 2 / 3"
(check-equal? (((currynr 2 list/kw 1) 2) 3) '(() () 3 2 1)))
(test-case "1 a"
(check-equal? (currynr 0 list/kw 1 #:a "a")
'((#:a) ("a") 1)))
(test-case "1 a / 2 b"
(check-equal? ((currynr 1 list/kw 1 #:a "a") 2 #:b "b")
'((#:a #:b) ("a" "b") 2 1)))
(test-case "1 a / 2 b / 3 c"
(check-equal? (((currynr 2 list/kw 1 #:a "a") 2 #:b "b") 3 #:c "c")
'((#:a #:b #:c) ("a" "b" "c") 3 2 1)))))
(test-suite "Eta Expansion"
(test-suite "eta"
(test-ok (define f (eta g))
(define g add1)
(check-equal? (f 1) 2)))
(test-suite "eta*"
(test-ok (define f (eta* g x))
(define g add1)
(check-equal? (f 1) 2))
(test-bad (define f (eta* g x))
(define g list)
(f 1 2))))
(test-suite "Parameter Arguments"
(test-suite "lambda/parameter"
(test-case "provided"
(let* ([p (make-parameter 0)])
(check = ((lambda/parameter ([x #:param p]) x) 1) 1)))
(test-case "not provided"
(let* ([p (make-parameter 0)])
(check = ((lambda/parameter ([x #:param p]) x)) 0)))
(test-case "argument order / provided"
(let* ([p (make-parameter 3)])
(check-equal? ((lambda/parameter (x [y 2] [z #:param p])
(list x y z))
4 5 6)
(list 4 5 6))))
(test-case "argument order / not provided"
(let* ([p (make-parameter 3)])
(check-equal? ((lambda/parameter (x [y 2] [z #:param p])
(list x y z))
1)
(list 1 2 3))))))))

2
collects/unstable/cce/test/test-main.ss
View File

@ -7,7 +7,6 @@
"test-define.ss"
"test-dict.ss"
"test-exn.ss"
"test-function.ss"
"test-hash.ss"
"test-match.ss"
"test-planet.ss"
@ -31,7 +30,6 @@
define-suite
dict-suite
exn-suite
function-suite
hash-suite
match-suite
planet-suite

2
collects/unstable/cce/web.ss
View File

@ -1,7 +1,7 @@
#lang scheme
(require xml
unstable/function
"define.ss"
"function.ss"
"text.ss")
;; css/c : FlatContract

16
collects/unstable/cce/function.ss → collects/unstable/function.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require scheme/dict scheme/match scheme/function "define.ss"
(for-syntax scheme/base scheme/list))
#lang racket/base
(require racket/dict racket/match racket/function
(for-syntax racket/base racket/list))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -93,14 +93,6 @@
(define (identity x) x)
(define-if-unbound (const v)
(make-intermediate-procedure
'constant-function
[(x ... 8) v]
[xs v]
#:keyword
[(ks vs . xs) v]))
(define-syntax (thunk stx)
(syntax-case stx ()
[(thunk body ...)
@ -374,7 +366,7 @@
(provide
;; functions
identity
thunk const
thunk
negate conjoin disjoin
curryn currynr papply papplyr call
;; macros

52
collects/unstable/cce/reference/function.scrbl → collects/unstable/scribblings/function.scrbl
View File

@ -1,13 +1,11 @@
#lang scribble/doc
@(require scribble/manual
scribble/eval
"../scribble.ss"
"eval.ss")
@(require (for-label scheme unstable/cce/function))
#lang scribble/manual
@(require scribble/eval "utils.rkt" (for-label racket unstable/function))
@title[#:style 'quiet #:tag "cce-function"]{Functions}
@title{Functions}
@defmodule[unstable/cce/function]
@defmodule[unstable/function]
@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
This module provides tools for higher-order programming and creating functions.
@ -25,7 +23,7 @@ Creates a function that ignores its inputs and evaluates the given body. Useful
for creating event handlers with no (or irrelevant) arguments.
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define f (thunk (define x 1) (printf "~a\n" x)))
(f)
(f 'x)
@ -34,24 +32,6 @@ for creating event handlers with no (or irrelevant) arguments.
}
@defproc[(const [x any/c]) (unconstrained-domain-> (one-of/c x))]{
Produces a function that returns @scheme[x] regardless of input.
This function is reprovided from @schememodname[scheme/function]. In versions
of PLT Scheme before @scheme[const] was implemented, this module provides its
own definition.
@defexamples[
#:eval (evaluator 'unstable/cce/function)
(define f (const 5))
(f)
(f 'x)
(f #:y 'z)
]
}
@section{Higher Order Predicates}
@defproc[((negate [f (-> A ... boolean?)]) [x A] ...) boolean?]{
@ -61,7 +41,7 @@ Negates the results of @scheme[f]; equivalent to @scheme[(not (f x ...))].
This function is reprovided from @schememodname[scheme/function].
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define f (negate exact-integer?))
(f 1)
(f 'one)
@ -75,7 +55,7 @@ Combines calls to each function with @scheme[and]. Equivalent to
@scheme[(and (f x ...) ...)]
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define f (conjoin exact? integer?))
(f 1)
(f 1.0)
@ -91,7 +71,7 @@ Combines calls to each function with @scheme[or]. Equivalent to
@scheme[(or (f x ...) ...)]
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define f (disjoin exact? integer?))
(f 1)
(f 1.0)
@ -109,7 +89,7 @@ Passes @scheme[x ...] to @scheme[f]. Keyword arguments are allowed. Equivalent
to @scheme[(f x ...)]. Useful for application in higher-order contexts.
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(map call
(list + - * /)
(list 1 2 3 4)
@ -141,7 +121,7 @@ equations:
]
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define reciprocal (papply / 1))
(reciprocal 3)
(reciprocal 4)
@ -189,7 +169,7 @@ to @scheme[curryn] and @scheme[currynr] in the following manner:
]
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define reciprocal (curryn 1 / 1))
(reciprocal 3)
@ -231,7 +211,7 @@ This is useful for function expressions that may be run, but not called, before
without evaluating @scheme[f].
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define f (eta g))
f
(define g (lambda (x) (+ x 1)))
@ -250,7 +230,7 @@ This macro behaves similarly to @scheme[eta], but produces a function with
statically known arity which may improve efficiency and error reporting.
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define f (eta* g x))
f
(procedure-arity f)
@ -276,7 +256,7 @@ argument @scheme[id] is @scheme[(param)]; @scheme[param] is bound to @scheme[id]
via @scheme[parameterize] during the function call.
@defexamples[
#:eval (evaluator 'unstable/cce/function)
#:eval (eval/require 'unstable/function)
(define p (open-output-string))
(define hello-world
(lambda/parameter ([port #:param current-output-port])

1
collects/unstable/scribblings/unstable.scrbl
View File

@ -76,6 +76,7 @@ Keep documentation and tests up to date.
@include-section["dirs.scrbl"]
@include-section["exn.scrbl"]
@include-section["file.scrbl"]
@include-section["function.scrbl"]
@include-section["list.scrbl"]
@include-section["net.scrbl"]
@include-section["path.scrbl"]

11
collects/unstable/scribblings/utils.rkt
View File

@ -1,8 +1,9 @@
#lang at-exp racket/base
(require scribble/base scribble/manual scribble/core)
(require scribble/base scribble/manual scribble/core scribble/eval)
(provide unstable
unstable-header
addition)
addition
eval/require)
(define (unstable . authors)
(make-compound-paragraph
@ -17,3 +18,9 @@
(define (addition name)
@margin-note{The subsequent bindings were added by @|name|.})
(define (eval/require . paths)
(let* ([e (make-base-eval)])
(for ([path (in-list paths)])
(e `(require ,path)))
e))