diff --git a/collects/tests/unstable/class.rkt b/collects/tests/unstable/class.rkt new file mode 100644 index 0000000000..e858bc41c4 --- /dev/null +++ b/collects/tests/unstable/class.rkt @@ -0,0 +1,94 @@ +#lang racket + +(require rackunit rackunit/text-ui unstable/class "helpers.rkt") + +(run-tests + (test-suite "class.ss" + + (test-suite "Predicates and Contracts" + + (test-suite "class-or-interface/c" + (test (check-ok (with/c class-or-interface/c object%))) + (test (check-ok (with/c class-or-interface/c (interface ())))) + (test (check-bad (with/c class-or-interface/c (new object%))))) + + (test-suite "object-provides/c" + (test-ok (with/c (object-provides/c) (new object%))) + (test-ok (define c% (class object% (super-new))) + (with/c (object-provides/c c%) (new c%))) + (test-ok (define i<%> (interface ())) + (define c% (class* object% (i<%>) (super-new))) + (with/c (object-provides/c i<%>) (new c%))) + (test-bad (define c% (class object% (super-new))) + (with/c (object-provides/c c%) (new object%))) + (test-bad (define i<%> (interface ())) + (with/c (object-provides/c i<%>) (new object%))) + (test-bad (with/c (object-provides/c) object%))) + + (test-suite "class-provides/c" + (test-ok (with/c (class-provides/c) object%)) + (test-ok (define c% (class object% (super-new))) + (with/c (class-provides/c c%) c%)) + (test-ok (define c% (class object% (super-new))) + (with/c (class-provides/c object%) c%)) + (test-ok (define i<%> (interface ())) + (define c% (class* object% (i<%>) (super-new))) + (with/c (class-provides/c i<%>) c%)) + (test-bad (define c% (class object% (super-new))) + (with/c (class-provides/c c%) object%)) + (test-bad (define i<%> (interface ())) + (with/c (class-provides/c i<%>) object%))) + + (test-suite "mixin-provides/c" + (test-ok ((with/c (mixin-provides/c [] []) values) object%)) + (test-bad (define i<%> (interface ())) + ((with/c (mixin-provides/c [i<%>] []) values) object%)) + (test-bad (define i<%> (interface ())) + ((with/c (mixin-provides/c [i<%>] []) values) object%)))) + + (test-suite "Mixins" + + (test-suite "ensure-interface" + (test-case "implementation unchanged" + (let* ([i<%> (interface ())] + [c% (class* object% (i<%>) (super-new))] + [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))]) + (check-eq? (ensure-interface i<%> mx c%) c%))) + (test-case "non-implementation subclassed" + (let* ([i<%> (interface ())] + [c% (class object% (super-new))] + [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))] + [result (ensure-interface i<%> mx c%)]) + (check-pred class? result) + (check subclass? result c%) + (check implementation? result i<%>))))) + + (test-suite "Messages" + + (test-suite "send+" + (test-case "no messages" + (let* ([o (new object%)]) + (check-eq? (send+ o) o))) + (test-case "multiple messages" + (let* ([c% (class object% + (super-new) + (init-field count) + (define/public (add n) (set! count (+ count n))) + (define/public (get) count))] + [o (new c% [count 0])]) + (check-eq? (send+ o [add 1] [add 2]) o) + (check = (send o get) 3)))) + + (test-suite "send-each" + (test-case "counter" + (let* ([c% (class object% + (super-new) + (init-field count) + (define/public (add n) (set! count (+ count n))) + (define/public (get) count))] + [o1 (new c% [count 1])] + [o2 (new c% [count 2])] + [o3 (new c% [count 3])]) + (send-each (list o1 o2 o3) add 3) + (check-equal? (list (send o1 get) (send o2 get) (send o3 get)) + (list 4 5 6)))))))) diff --git a/collects/unstable/cce/reference/manual.scrbl b/collects/unstable/cce/reference/manual.scrbl index 7a725fc802..4c61daf275 100644 --- a/collects/unstable/cce/reference/manual.scrbl +++ b/collects/unstable/cce/reference/manual.scrbl @@ -16,8 +16,6 @@ @include-section["syntax.scrbl"] @include-section["define.scrbl"] -@include-section["class.scrbl"] - @include-section["require-provide.scrbl"] @include-section["planet.scrbl"] diff --git a/collects/unstable/cce/test/test-class.ss b/collects/unstable/cce/test/test-class.ss deleted file mode 100644 index 74cefeff19..0000000000 --- a/collects/unstable/cce/test/test-class.ss +++ /dev/null @@ -1,97 +0,0 @@ -#lang scheme - -(require "checks.ss" - "../class.ss") - -(provide class-suite) - -(define class-suite - (test-suite "class.ss" - - (test-suite "Predicates and Contracts" - - (test-suite "class-or-interface/c" - (test (check-ok (with/c class-or-interface/c object%))) - (test (check-ok (with/c class-or-interface/c (interface ())))) - (test (check-bad (with/c class-or-interface/c (new object%))))) - - (test-suite "object-provides/c" - (test-ok (with/c (object-provides/c) (new object%))) - (test-ok (define c% (class object% (super-new))) - (with/c (object-provides/c c%) (new c%))) - (test-ok (define i<%> (interface ())) - (define c% (class* object% (i<%>) (super-new))) - (with/c (object-provides/c i<%>) (new c%))) - (test-bad (define c% (class object% (super-new))) - (with/c (object-provides/c c%) (new object%))) - (test-bad (define i<%> (interface ())) - (with/c (object-provides/c i<%>) (new object%))) - (test-bad (with/c (object-provides/c) object%))) - - (test-suite "class-provides/c" - (test-ok (with/c (class-provides/c) object%)) - (test-ok (define c% (class object% (super-new))) - (with/c (class-provides/c c%) c%)) - (test-ok (define c% (class object% (super-new))) - (with/c (class-provides/c object%) c%)) - (test-ok (define i<%> (interface ())) - (define c% (class* object% (i<%>) (super-new))) - (with/c (class-provides/c i<%>) c%)) - (test-bad (define c% (class object% (super-new))) - (with/c (class-provides/c c%) object%)) - (test-bad (define i<%> (interface ())) - (with/c (class-provides/c i<%>) object%))) - - (test-suite "mixin-provides/c" - (test-ok ((with/c (mixin-provides/c [] []) values) object%)) - (test-bad (define i<%> (interface ())) - ((with/c (mixin-provides/c [i<%>] []) values) object%)) - (test-bad (define i<%> (interface ())) - ((with/c (mixin-provides/c [i<%>] []) values) object%)))) - - (test-suite "Mixins" - - (test-suite "ensure-interface" - (test-case "implementation unchanged" - (let* ([i<%> (interface ())] - [c% (class* object% (i<%>) (super-new))] - [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))]) - (check-eq? (ensure-interface i<%> mx c%) c%))) - (test-case "non-implementation subclassed" - (let* ([i<%> (interface ())] - [c% (class object% (super-new))] - [mx (lambda (parent%) (class* parent% (i<%>) (super-new)))] - [result (ensure-interface i<%> mx c%)]) - (check-pred class? result) - (check subclass? result c%) - (check implementation? result i<%>))))) - - (test-suite "Messages" - - (test-suite "send+" - (test-case "no messages" - (let* ([o (new object%)]) - (check-eq? (send+ o) o))) - (test-case "multiple messages" - (let* ([c% (class object% - (super-new) - (init-field count) - (define/public (add n) (set! count (+ count n))) - (define/public (get) count))] - [o (new c% [count 0])]) - (check-eq? (send+ o [add 1] [add 2]) o) - (check = (send o get) 3)))) - - (test-suite "send-each" - (test-case "counter" - (let* ([c% (class object% - (super-new) - (init-field count) - (define/public (add n) (set! count (+ count n))) - (define/public (get) count))] - [o1 (new c% [count 1])] - [o2 (new c% [count 2])] - [o3 (new c% [count 3])]) - (send-each (list o1 o2 o3) add 3) - (check-equal? (list (send o1 get) (send o2 get) (send o3 get)) - (list 4 5 6)))))))) diff --git a/collects/unstable/cce/test/test-main.ss b/collects/unstable/cce/test/test-main.ss index 2ccefeb3d9..fc7cf8aa7b 100644 --- a/collects/unstable/cce/test/test-main.ss +++ b/collects/unstable/cce/test/test-main.ss @@ -1,7 +1,6 @@ #lang scheme (require "checks.ss" - "test-class.ss" "test-debug.ss" "test-define.ss" "test-dict.ss" @@ -13,7 +12,6 @@ (run-tests (test-suite "scheme.plt" - class-suite debug-suite define-suite dict-suite diff --git a/collects/unstable/cce/class.ss b/collects/unstable/class.rkt similarity index 96% rename from collects/unstable/cce/class.ss rename to collects/unstable/class.rkt index 3bec440271..3b21a1d3d7 100644 --- a/collects/unstable/cce/class.ss +++ b/collects/unstable/class.rkt @@ -1,6 +1,6 @@ -#lang scheme/base -(require scheme/contract scheme/class - (for-syntax scheme/base)) +#lang racket/base +(require racket/contract racket/class + (for-syntax racket/base)) (define class-or-interface/c (or/c class? interface?)) diff --git a/collects/unstable/cce/reference/class.scrbl b/collects/unstable/scribblings/class.scrbl similarity index 84% rename from collects/unstable/cce/reference/class.scrbl rename to collects/unstable/scribblings/class.scrbl index d17ce1e149..be86f1e277 100644 --- a/collects/unstable/cce/reference/class.scrbl +++ b/collects/unstable/scribblings/class.scrbl @@ -1,13 +1,11 @@ -#lang scribble/doc -@(require scribble/manual - scribble/eval - "../scribble.ss" - "eval.ss") -@(require (for-label scheme unstable/cce/class)) +#lang scribble/manual +@(require scribble/eval "utils.rkt" (for-label racket unstable/class)) -@title[#:style 'quiet #:tag "cce-class"]{Classes and Objects} +@title{Classes and Objects} -@defmodule[unstable/cce/class] +@defmodule[unstable/class] + +@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]] This module provides tools for classes, objects, and mixins. @@ -59,7 +57,7 @@ Returns @scheme[c%] if it implements @scheme[i<%>]; otherwise, returns Sends each message (with arguments) to @scheme[obj], then returns @scheme[obj]. @defexamples[ -#:eval (evaluator 'unstable/cce/class) +#:eval (eval/require 'racket/class 'unstable/class) (define c% (class object% (super-new) @@ -75,7 +73,7 @@ Sends the message to each object in the list @scheme[objs], returning @scheme[(void)]. @defexamples[ -#:eval (evaluator 'unstable/cce/class) +#:eval (eval/require 'racket/class 'unstable/class) (define c% (class object% (super-new) diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 52500d3488..402226515a 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -72,6 +72,7 @@ Keep documentation and tests up to date. } @include-section["bytes.scrbl"] +@include-section["class.scrbl"] @include-section["contract.scrbl"] @include-section["dirs.scrbl"] @include-section["exn.scrbl"]