From 6f39c3fca120466b53d416bf6d0282a05e79d240 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 22 May 2010 13:43:13 -0400 Subject: [PATCH] Adding contents of (planet cce/scheme:7) to collects/unstable/cce. This is a staging area; these modules will be adapted to collects/unstable. --- collects/unstable/cce/class.ss | 74 ++++ collects/unstable/cce/contract.ss | 268 ++++++++++++ collects/unstable/cce/debug.ss | 161 +++++++ collects/unstable/cce/define.ss | 140 ++++++ collects/unstable/cce/dict.ss | 279 ++++++++++++ collects/unstable/cce/drscheme.ss | 198 +++++++++ collects/unstable/cce/exn.ss | 11 + collects/unstable/cce/function.ss | 382 ++++++++++++++++ collects/unstable/cce/gui.ss | 92 ++++ collects/unstable/cce/hash.ss | 136 ++++++ collects/unstable/cce/info.ss | 3 + collects/unstable/cce/match.ss | 127 ++++++ collects/unstable/cce/planet.ss | 26 ++ collects/unstable/cce/port.ss | 56 +++ collects/unstable/cce/private/define-core.ss | 68 +++ collects/unstable/cce/private/syntax-core.ss | 160 +++++++ collects/unstable/cce/queue.ss | 58 +++ collects/unstable/cce/reference/class.scrbl | 90 ++++ .../unstable/cce/reference/contract.scrbl | 131 ++++++ collects/unstable/cce/reference/debug.scrbl | 71 +++ collects/unstable/cce/reference/define.scrbl | 176 ++++++++ collects/unstable/cce/reference/dict.scrbl | 300 +++++++++++++ .../unstable/cce/reference/drscheme.scrbl | 138 ++++++ collects/unstable/cce/reference/eval.ss | 10 + collects/unstable/cce/reference/exn.scrbl | 31 ++ .../unstable/cce/reference/function.scrbl | 289 ++++++++++++ collects/unstable/cce/reference/gui.scrbl | 80 ++++ collects/unstable/cce/reference/hash.scrbl | 223 ++++++++++ collects/unstable/cce/reference/manual.scrbl | 49 +++ collects/unstable/cce/reference/match.scrbl | 81 ++++ collects/unstable/cce/reference/planet.scrbl | 35 ++ collects/unstable/cce/reference/port.scrbl | 105 +++++ collects/unstable/cce/reference/queue.scrbl | 67 +++ collects/unstable/cce/reference/regexp.scrbl | 129 ++++++ .../cce/reference/require-provide.scrbl | 107 +++++ collects/unstable/cce/reference/sandbox.scrbl | 66 +++ .../unstable/cce/reference/scribble.scrbl | 77 ++++ collects/unstable/cce/reference/set.scrbl | 414 ++++++++++++++++++ .../unstable/cce/reference/slideshow.scrbl | 314 +++++++++++++ collects/unstable/cce/reference/syntax.scrbl | 387 ++++++++++++++++ collects/unstable/cce/reference/text.scrbl | 170 +++++++ collects/unstable/cce/reference/values.scrbl | 86 ++++ collects/unstable/cce/reference/web.scrbl | 58 +++ collects/unstable/cce/regexp.ss | 59 +++ collects/unstable/cce/require-provide.ss | 160 +++++++ collects/unstable/cce/sandbox.ss | 67 +++ collects/unstable/cce/scribble.ss | 72 +++ collects/unstable/cce/set.ss | 292 ++++++++++++ collects/unstable/cce/slideshow.ss | 307 +++++++++++++ collects/unstable/cce/syntax.ss | 278 ++++++++++++ collects/unstable/cce/test/checks.ss | 79 ++++ collects/unstable/cce/test/test-class.ss | 97 ++++ collects/unstable/cce/test/test-contract.ss | 83 ++++ collects/unstable/cce/test/test-debug.ss | 24 + collects/unstable/cce/test/test-define.ss | 99 +++++ collects/unstable/cce/test/test-dict.ss | 110 +++++ collects/unstable/cce/test/test-exn.ss | 15 + collects/unstable/cce/test/test-function.ss | 157 +++++++ collects/unstable/cce/test/test-hash.ss | 74 ++++ collects/unstable/cce/test/test-main.ss | 48 ++ collects/unstable/cce/test/test-match.ss | 45 ++ collects/unstable/cce/test/test-planet.ss | 11 + collects/unstable/cce/test/test-port.ss | 52 +++ collects/unstable/cce/test/test-queue.ss | 56 +++ collects/unstable/cce/test/test-regexp.ss | 50 +++ .../unstable/cce/test/test-require-provide.ss | 9 + collects/unstable/cce/test/test-sandbox.ss | 9 + collects/unstable/cce/test/test-scribble.ss | 10 + collects/unstable/cce/test/test-set.ss | 169 +++++++ collects/unstable/cce/test/test-syntax.ss | 256 +++++++++++ collects/unstable/cce/test/test-text.ss | 136 ++++++ collects/unstable/cce/test/test-values.ss | 63 +++ collects/unstable/cce/test/test-web.ss | 22 + collects/unstable/cce/text.ss | 129 ++++++ collects/unstable/cce/values.ss | 63 +++ collects/unstable/cce/web.ss | 98 +++++ collects/unstable/scribblings/unstable.scrbl | 3 + 77 files changed, 9125 insertions(+) create mode 100644 collects/unstable/cce/class.ss create mode 100644 collects/unstable/cce/contract.ss create mode 100644 collects/unstable/cce/debug.ss create mode 100644 collects/unstable/cce/define.ss create mode 100644 collects/unstable/cce/dict.ss create mode 100644 collects/unstable/cce/drscheme.ss create mode 100644 collects/unstable/cce/exn.ss create mode 100644 collects/unstable/cce/function.ss create mode 100644 collects/unstable/cce/gui.ss create mode 100644 collects/unstable/cce/hash.ss create mode 100644 collects/unstable/cce/info.ss create mode 100644 collects/unstable/cce/match.ss create mode 100644 collects/unstable/cce/planet.ss create mode 100644 collects/unstable/cce/port.ss create mode 100644 collects/unstable/cce/private/define-core.ss create mode 100644 collects/unstable/cce/private/syntax-core.ss create mode 100644 collects/unstable/cce/queue.ss create mode 100644 collects/unstable/cce/reference/class.scrbl create mode 100644 collects/unstable/cce/reference/contract.scrbl create mode 100644 collects/unstable/cce/reference/debug.scrbl create mode 100644 collects/unstable/cce/reference/define.scrbl create mode 100644 collects/unstable/cce/reference/dict.scrbl create mode 100644 collects/unstable/cce/reference/drscheme.scrbl create mode 100644 collects/unstable/cce/reference/eval.ss create mode 100644 collects/unstable/cce/reference/exn.scrbl create mode 100644 collects/unstable/cce/reference/function.scrbl create mode 100644 collects/unstable/cce/reference/gui.scrbl create mode 100644 collects/unstable/cce/reference/hash.scrbl create mode 100644 collects/unstable/cce/reference/manual.scrbl create mode 100644 collects/unstable/cce/reference/match.scrbl create mode 100644 collects/unstable/cce/reference/planet.scrbl create mode 100644 collects/unstable/cce/reference/port.scrbl create mode 100644 collects/unstable/cce/reference/queue.scrbl create mode 100644 collects/unstable/cce/reference/regexp.scrbl create mode 100644 collects/unstable/cce/reference/require-provide.scrbl create mode 100644 collects/unstable/cce/reference/sandbox.scrbl create mode 100644 collects/unstable/cce/reference/scribble.scrbl create mode 100644 collects/unstable/cce/reference/set.scrbl create mode 100644 collects/unstable/cce/reference/slideshow.scrbl create mode 100644 collects/unstable/cce/reference/syntax.scrbl create mode 100644 collects/unstable/cce/reference/text.scrbl create mode 100644 collects/unstable/cce/reference/values.scrbl create mode 100644 collects/unstable/cce/reference/web.scrbl create mode 100644 collects/unstable/cce/regexp.ss create mode 100644 collects/unstable/cce/require-provide.ss create mode 100644 collects/unstable/cce/sandbox.ss create mode 100644 collects/unstable/cce/scribble.ss create mode 100644 collects/unstable/cce/set.ss create mode 100644 collects/unstable/cce/slideshow.ss create mode 100644 collects/unstable/cce/syntax.ss create mode 100644 collects/unstable/cce/test/checks.ss create mode 100644 collects/unstable/cce/test/test-class.ss create mode 100644 collects/unstable/cce/test/test-contract.ss create mode 100644 collects/unstable/cce/test/test-debug.ss create mode 100644 collects/unstable/cce/test/test-define.ss create mode 100644 collects/unstable/cce/test/test-dict.ss create mode 100644 collects/unstable/cce/test/test-exn.ss create mode 100644 collects/unstable/cce/test/test-function.ss create mode 100644 collects/unstable/cce/test/test-hash.ss create mode 100644 collects/unstable/cce/test/test-main.ss create mode 100644 collects/unstable/cce/test/test-match.ss create mode 100644 collects/unstable/cce/test/test-planet.ss create mode 100644 collects/unstable/cce/test/test-port.ss create mode 100644 collects/unstable/cce/test/test-queue.ss create mode 100644 collects/unstable/cce/test/test-regexp.ss create mode 100644 collects/unstable/cce/test/test-require-provide.ss create mode 100644 collects/unstable/cce/test/test-sandbox.ss create mode 100644 collects/unstable/cce/test/test-scribble.ss create mode 100644 collects/unstable/cce/test/test-set.ss create mode 100644 collects/unstable/cce/test/test-syntax.ss create mode 100644 collects/unstable/cce/test/test-text.ss create mode 100644 collects/unstable/cce/test/test-values.ss create mode 100644 collects/unstable/cce/test/test-web.ss create mode 100644 collects/unstable/cce/text.ss create mode 100644 collects/unstable/cce/values.ss create mode 100644 collects/unstable/cce/web.ss diff --git a/collects/unstable/cce/class.ss b/collects/unstable/cce/class.ss new file mode 100644 index 0000000000..3bec440271 --- /dev/null +++ b/collects/unstable/cce/class.ss @@ -0,0 +1,74 @@ +#lang scheme/base +(require scheme/contract scheme/class + (for-syntax scheme/base)) + +(define class-or-interface/c (or/c class? interface?)) + +(define (subclass-or-implements/c class-or-iface) + (cond + [(class? class-or-iface) (subclass?/c class-or-iface)] + [(interface? class-or-iface) (implementation?/c class-or-iface)] + [else (error 'subclass-or-implements/c + "not a class or interface: ~s" + class-or-iface)])) + +(define (object-provides/c . class-or-ifaces) + (apply and/c object? (map is-a?/c class-or-ifaces))) + +(define (class-provides/c . class-or-ifaces) + (apply and/c class? (map subclass-or-implements/c class-or-ifaces))) + +(define-syntax (mixin-provides/c stx) + (syntax-case stx () + [(form (super-in ...) + (sub-out ...)) + (with-syntax ([(super-var ...) + (generate-temporaries (syntax (super-in ...)))] + [(sub-var ...) + (generate-temporaries (syntax (sub-out ...)))]) + (syntax/loc stx + (let* ([super-var super-in] ... + [sub-var sub-out] ...) + (->d ([super (class-provides/c super-var ...)]) + () + [_ (class-provides/c super sub-var ...)]))))])) + +(define-syntax (send+ stx) + (syntax-case stx () + [(s+ expr clause ...) + (syntax/loc stx + (let* ([obj expr]) + (send obj . clause) ... + obj))])) + +(define-syntax (send-each stx) + (syntax-case stx () + [(se objs-expr method arg-expr ...) + (with-syntax ([(arg-var ...) (generate-temporaries #'(arg-expr ...))]) + (syntax/loc stx + (let ([objs-var objs-expr] + [arg-var arg-expr] + ...) + (for-each (lambda (obj) + (send obj method arg-var ...)) + objs-var))))])) + +(define (ensure-interface iface<%> mx class%) + (if (implementation? class% iface<%>) + class% + (mx class%))) + +(provide/contract + [class-or-interface/c flat-contract?] + [object-provides/c + (->* [] [] #:rest (listof class-or-interface/c) flat-contract?)] + [class-provides/c + (->* [] [] #:rest (listof class-or-interface/c) flat-contract?)] + [ensure-interface + (->d ([the-interface interface?] + [the-mixin (mixin-provides/c [] [the-interface])] + [the-class class?]) + () + [_ (class-provides/c the-class the-interface)])]) + +(provide mixin-provides/c send+ send-each) diff --git a/collects/unstable/cce/contract.ss b/collects/unstable/cce/contract.ss new file mode 100644 index 0000000000..ad1277ec85 --- /dev/null +++ b/collects/unstable/cce/contract.ss @@ -0,0 +1,268 @@ +#lang scheme + +(require (for-syntax syntax/parse)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Flat Contracts +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define nat/c + (flat-named-contract '|natural number| exact-nonnegative-integer?)) + +(define pos/c + (flat-named-contract '|positive integer| exact-positive-integer?)) + +(define truth/c + (flat-named-contract '|truth value| (lambda (x) #t))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Function Contracts +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define thunk/c (-> any/c)) +(define unary/c (-> any/c any/c)) +(define binary/c (-> any/c any/c any/c)) +(define predicate/c (-> any/c boolean?)) +(define comparison/c (-> any/c any/c boolean?)) +(define predicate-like/c (-> any/c truth/c)) +(define comparison-like/c (-> any/c any/c truth/c)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Contracted Sequences +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (sequence/c . elem/cs) + (let* ([elem/cs (for/list ([elem/c (in-list elem/cs)]) + (coerce-contract 'sequence/c elem/c))] + [n-cs (length elem/cs)]) + (make-proj-contract + (apply build-compound-type-name 'sequence/c elem/cs) + (lambda (pos neg src name blame) + (lambda (seq) + (unless (sequence? seq) + (raise-contract-error + seq src pos name + "expected a sequence, got: ~e" + seq)) + (make-do-sequence + (lambda () + (let*-values ([(more? next) (sequence-generate seq)]) + (values + (lambda (idx) + (call-with-values next + (lambda elems + (define n-elems (length elems)) + (unless (= n-elems n-cs) + (raise-contract-error + seq src pos name + "expected a sequence of ~a values, got ~a values: ~s" + n-cs n-elems elems)) + (apply + values + (for/list ([elem (in-list elems)] + [elem/c (in-list elem/cs)]) + ((((proj-get elem/c) elem/c) pos neg src name blame) elem)))))) + (lambda (idx) idx) + #f + (lambda (idx) (more?)) + (lambda (elem) #t) + (lambda (idx elem) #t))))))) + sequence?))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Contracted Dictionaries +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; A CDict is (make-contracted-dictionary (Listof (Cons Proj Proj)) Dict) +;; A Proj is (make-projection Contract Symbol Symbol Any Any) +(define-struct contracted-dictionary [projections bindings]) +(define-struct projection [contract out in source name blame]) + +(define (dict/c key/c value/c) + (let* ([key/c (coerce-contract 'dict/c key/c)] + [value/c (coerce-contract 'dict/c value/c)]) + (make-proj-contract + (build-compound-type-name 'dict/c key/c value/c) + (lambda (pos neg src name blame) + (lambda (dict) + (unless (dict? dict) + (raise-contract-error dict src pos name + "expected a dictionary, got: ~e" + dict)) + (wrap + (cons (cons (make-projection key/c pos neg src name blame) + (make-projection value/c pos neg src name blame)) + (dict->projections dict)) + (dict->bindings dict)))) + dict?))) + +(define-match-expander cdict + (syntax-rules () [(_ p b) (struct contracted-dictionary [p b])])) + +(define-match-expander proj + (syntax-rules () [(_ c o i s n b) (struct projection [c o i s n b])])) + +(define -ref + (case-lambda + [(dict key) + (match dict + [(cdict projs binds) + (let* ([key (key-in projs key)]) + (value-out projs (dict-ref binds key)))])] + [(dict key failure) + (match dict + [(cdict projs binds) + (let* ([key (key-in projs key)]) + (let/ec return + (define (fail) + (return (if (procedure? failure) (failure) failure))) + (value-out projs (dict-ref binds key fail))))])])) + +(define (-set! dict key value) + (match dict + [(cdict projs binds) + (dict-set! binds (key-in projs key) (value-in projs value))])) + +(define (-set dict key value) + (match dict + [(cdict projs binds) + (wrap projs (dict-set binds (key-in projs key) (value-in projs value)))])) + +(define (-rem! dict key) + (match dict + [(cdict projs binds) + (dict-remove! binds (key-in projs key))])) + +(define (-rem dict key) + (match dict + [(cdict projs binds) + (wrap projs (dict-remove binds (key-in projs key)))])) + +(define (-size dict) + (match dict + [(cdict projs binds) + (dict-count binds)])) + +(define (-fst dict) + (match dict + [(cdict projs binds) + (dict-iterate-first binds)])) + +(define (-nxt dict iter) + (match dict + [(cdict projs binds) + (dict-iterate-next binds iter)])) + +(define (-key dict iter) + (match dict + [(cdict projs binds) + (key-out projs (dict-iterate-key binds iter))])) + +(define (-val dict iter) + (match dict + [(cdict projs binds) + (value-out projs (dict-iterate-value binds iter))])) + +(define (key-in projs key) + (if (null? projs) + key + (key-in (cdr projs) (project-in (caar projs) key)))) + +(define (value-in projs value) + (if (null? projs) + value + (value-in (cdr projs) (project-in (cdar projs) value)))) + +(define (key-out projs key) + (if (null? projs) + key + (project-out (caar projs) (key-out (cdr projs) key)))) + +(define (value-out projs value) + (if (null? projs) + value + (project-out (cdar projs) (value-out (cdr projs) value)))) + +(define (project-in p x) + (match p + [(proj c o i s n b) + ((((proj-get c) c) i o s n (not b)) x)])) + +(define (project-out p x) + (match p + [(proj c o i s n b) + ((((proj-get c) c) o i s n b) x)])) + +(define (dict->bindings dict) + (match dict + [(cdict projs binds) binds] + [_ dict])) + +(define (dict->projections dict) + (match dict + [(cdict projs binds) projs] + [_ null])) + +(define (wrap projs binds) + ((dict->wrapper binds) projs binds)) + +(define (dict->wrapper dict) + (if (dict-mutable? dict) + (if (dict-can-functional-set? dict) + (if (dict-can-remove-keys? dict) make-:!+- make-:!+_) + (if (dict-can-remove-keys? dict) make-:!_- make-:!__)) + (if (dict-can-functional-set? dict) + (if (dict-can-remove-keys? dict) make-:_+- make-:_+_) + (if (dict-can-remove-keys? dict) make-:__- make-:___)))) + +;; The __- case (removal without functional or mutable update) is nonsensical. +(define prop:!+- (vector -ref -set! -set -rem! -rem -size -fst -nxt -key -val)) +(define prop:!+_ (vector -ref -set! -set #f #f -size -fst -nxt -key -val)) +(define prop:!_- (vector -ref -set! #f -rem! #f -size -fst -nxt -key -val)) +(define prop:!__ (vector -ref -set! #f #f #f -size -fst -nxt -key -val)) +(define prop:_+- (vector -ref #f -set #f -rem -size -fst -nxt -key -val)) +(define prop:_+_ (vector -ref #f -set #f -rem -size -fst -nxt -key -val)) +(define prop:__- (vector -ref #f #f #f #f -size -fst -nxt -key -val)) +(define prop:___ (vector -ref #f #f #f #f -size -fst -nxt -key -val)) + +;; The __- case (removal without functional or mutable update) is nonsensical. +(define-struct (:!+- contracted-dictionary) [] #:property prop:dict prop:!+-) +(define-struct (:!+_ contracted-dictionary) [] #:property prop:dict prop:!+_) +(define-struct (:!_- contracted-dictionary) [] #:property prop:dict prop:!_-) +(define-struct (:!__ contracted-dictionary) [] #:property prop:dict prop:!__) +(define-struct (:_+- contracted-dictionary) [] #:property prop:dict prop:_+-) +(define-struct (:_+_ contracted-dictionary) [] #:property prop:dict prop:_+_) +(define-struct (:__- contracted-dictionary) [] #:property prop:dict prop:__-) +(define-struct (:___ contracted-dictionary) [] #:property prop:dict prop:___) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Exports +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide/contract + + [nat/c flat-contract?] + [pos/c flat-contract?] + [truth/c flat-contract?] + + [thunk/c contract?] + [unary/c contract?] + [binary/c contract?] + [predicate/c contract?] + [comparison/c contract?] + [predicate-like/c contract?] + [comparison-like/c contract?] + + [sequence/c (->* [] [] #:rest (listof contract?) contract?)] + [dict/c (-> contract? contract? contract?)] + ) diff --git a/collects/unstable/cce/debug.ss b/collects/unstable/cce/debug.ss new file mode 100644 index 0000000000..ce9de45894 --- /dev/null +++ b/collects/unstable/cce/debug.ss @@ -0,0 +1,161 @@ +#lang scheme + +(provide debug + dprintf + begin/debug + define/debug + define/private/debug + define/public/debug + define/override/debug + define/augment/debug + let/debug + let*/debug + letrec/debug + let-values/debug + let*-values/debug + letrec-values/debug + with-syntax/debug + with-syntax*/debug + parameterize/debug + with-debugging) + +(require unstable/srcloc + unstable/location + unstable/syntax + (for-syntax scheme/match syntax/parse unstable/syntax)) + +(define-syntax (let/debug stx) + (syntax-parse stx + [(_ (~optional loop:id) ([lhs:id rhs:expr] ...) body:expr ...+) + #`(with-debugging + #:name '#,(if (attribute loop) #'loop #'let/debug) + #:source (quote-srcloc #,stx) + (let #,@(if (attribute loop) (list #'loop) null) + ([lhs (with-debugging #:name 'lhs rhs)] ...) + (debug body) ...))])) + +(define-syntaxes + [ let*/debug + letrec/debug + let-values/debug + let*-values/debug + letrec-values/debug + with-syntax/debug + with-syntax*/debug + parameterize/debug ] + + (let () + + (define ((expander binder-id) stx) + (with-syntax ([binder binder-id]) + (syntax-parse stx + [(binder/debug:id ([lhs rhs:expr] ...) body:expr ...+) + #`(with-debugging + #:name 'binder/debug + #:source (quote-srcloc #,stx) + (binder + ([lhs (with-debugging #:name 'lhs rhs)] ...) + (debug body) ...))]))) + + (values (expander #'let*) + (expander #'letrec) + (expander #'let-values) + (expander #'let*-values) + (expander #'letrec-values) + (expander #'with-syntax) + (expander #'with-syntax*) + (expander #'parameterize)))) + +(define-syntaxes + [ define/debug + define/private/debug + define/public/debug + define/override/debug + define/augment/debug ] + + (let () + + (define-syntax-class header + #:attributes [name] + (pattern (name:id . _)) + (pattern (inner:header . _) #:attr name (attribute inner.name))) + + (define ((expander definer-id) stx) + (with-syntax ([definer definer-id]) + (syntax-parse stx + [(definer/debug:id name:id body:expr) + #`(definer name + (with-debugging + #:name 'name + #:source (quote-srcloc #,stx) + body))] + [(definer/debug:id spec:header body:expr ...+) + #`(definer spec + (with-debugging + #:name 'spec.name + #:source (quote-srcloc #,stx) + (let () body ...)))]))) + + (values (expander #'define) + (expander #'define/private) + (expander #'define/public) + (expander #'define/override) + (expander #'define/augment)))) + +(define-syntax (begin/debug stx) + (syntax-parse stx + [(_ term:expr ...) + #`(with-debugging + #:name 'begin/debug + #:source (quote-srcloc #,stx) + (begin (debug term) ...))])) + +(define-syntax (debug stx) + (syntax-parse stx + [(_ term:expr) + (syntax (with-debugging term))])) + +(define-syntax (with-debugging stx) + (syntax-parse stx + [(_ (~or (~optional (~seq #:name name:expr)) + (~optional (~seq #:source source:expr))) + ... + body:expr) + (with-syntax* ([name (or (attribute name) #'(quote body))] + [source (or (attribute source) #'(quote-srcloc body))]) + #'(with-debugging/proc + name + source + (quote body) + (lambda () (#%expression body))))])) + +(define (with-debugging/proc name source term thunk) + (let* ([src (source-location->prefix source)]) + (begin + (dprintf ">> ~a~s" src name) + (begin0 + (parameterize ([current-debug-depth + (add1 (current-debug-depth))]) + (call-with-values thunk + (lambda results + (match results + [(list v) (dprintf "~s" v)] + [(list vs ...) + (dprintf "(values~a)" + (apply string-append + (for/list ([v (in-list vs)]) + (format " ~s" v))))]) + (apply values results)))) + (dprintf "<< ~a~s" src name))))) + +(define (dprintf fmt . args) + (let* ([message (apply format fmt args)] + [prefix (make-string (* debug-indent (current-debug-depth)) #\space)] + [indented + (string-append + prefix + (regexp-replace* "\n" message (string-append "\n" prefix)))]) + (log-debug indented))) + +(define current-debug-depth (make-parameter 0)) +(define debug-indent 2) diff --git a/collects/unstable/cce/define.ss b/collects/unstable/cce/define.ss new file mode 100644 index 0000000000..e7ac65c3ab --- /dev/null +++ b/collects/unstable/cce/define.ss @@ -0,0 +1,140 @@ +#lang scheme + +(require "private/define-core.ss" + (for-syntax scheme/match + syntax/kerncase + "syntax.ss")) + +(provide + + in-phase1 in-phase1/pass2 + + block + at-end + + declare-names + define-renamings + define-single-definition + define-with-parameter + + define-if-unbound + define-values-if-unbound + define-syntax-if-unbound + define-syntaxes-if-unbound) + +(define-syntax (at-end stx) + (syntax-case stx () + [(_ e ...) + (match (syntax-local-context) + ['module + (begin + (syntax-local-lift-module-end-declaration + (syntax/loc stx (begin e ...))) + (syntax/loc stx (begin)))] + [ctx (syntax-error stx + "can only be used in module context; got: ~s" + ctx)])])) + +(define-syntax-rule (define-with-parameter name parameter) + (define-syntax-rule (name value body (... ...)) + (parameterize ([parameter value]) body (... ...)))) + +(define-syntax (#%definition stx0) + (syntax-case stx0 () + [(_ form) + (let* ([stx (head-expand #'form)]) + (syntax-case stx ( module + #%require + #%provide + define-values + define-syntaxes + define-values-for-syntax + begin ) + [(module . _) stx] + [(#%require . _) stx] + [(#%provide . _) stx] + [(define-values . _) stx] + [(define-syntaxes . _) stx] + [(define-values-for-syntax . _) stx] + [(begin d ...) (syntax/loc stx0 (begin (#%definition d) ...))] + [_ (raise-syntax-error '#%definition "not a definition" stx0 stx)]))])) + +(define-syntax (#%as-definition stx0) + (syntax-case stx0 () + [(_ form) + (let* ([stx (head-expand #'form)]) + (syntax-case stx ( module + #%require + #%provide + define-values + define-syntaxes + define-values-for-syntax + begin ) + [(module . _) stx] + [(#%require . _) stx] + [(#%provide . _) stx] + [(define-values . _) stx] + [(define-syntaxes . _) stx] + [(define-values-for-syntax . _) stx] + [(begin d ...) (syntax/loc stx0 (begin (#%as-definition d) ...))] + [e + (syntax/loc stx0 + (define-values [] (begin e (#%plain-app values))))]))])) + +(define-syntax (#%as-expression stx0) + (syntax-case stx0 () + [(_ form) + (let* ([stx (head-expand #'form)] + ;; pre-compute this to save duplicated code below + [done (quasisyntax/loc stx0 (begin #,stx (#%plain-app void)))]) + (syntax-case stx ( module + #%require + #%provide + define-values + define-syntaxes + define-values-for-syntax + begin ) + [(module . _) done] + [(#%require . _) done] + [(#%provide . _) done] + [(define-values . _) done] + [(define-syntaxes . _) done] + [(define-values-for-syntax . _) done] + [(begin) (syntax/loc stx0 (#%plain-app void))] + [(begin d ... e) + (syntax/loc stx0 (begin (#%as-definition d) ... (#%as-expression e)))] + [_ stx]))])) + +(define-syntax-rule (block form ...) + (let-values () (#%as-expression (begin form ...)))) + +(define-syntax (declare-names stx) + (match (syntax-local-context) + ['top-level + (syntax-case stx [] + [(_ name ...) (syntax/loc stx (define-syntaxes [name ...] (values)))])] + [_ (syntax/loc stx (begin))])) + +(define-syntax-rule (define-renamings [new old] ...) + (define-syntaxes [new ...] (values (make-rename-transformer #'old) ...))) + +(define-syntax (in-phase1 stx) + (syntax-case stx [] + [(_ e) + (match (syntax-local-context) + ['expression (syntax/loc stx (let-syntax ([dummy e]) (void)))] + [(or 'module 'top-level (? pair?)) + (syntax/loc stx + (begin + (define-syntax (macro stx*) (begin e (syntax/loc stx* (begin)))) + (macro)))] + ['module-begin (syntax-error stx "cannot be used as module body")])])) + +(define-syntax (in-phase1/pass2 stx) + (syntax-case stx [] + [(_ e) + (match (syntax-local-context) + [(? pair?) + (syntax/loc stx (define-values [] (begin (in-phase1 e) (values))))] + [(or 'expression 'top-level 'module 'module-begin) + (syntax/loc stx (#%expression (in-phase1 e)))])])) diff --git a/collects/unstable/cce/dict.ss b/collects/unstable/cce/dict.ss new file mode 100644 index 0000000000..44e02bf667 --- /dev/null +++ b/collects/unstable/cce/dict.ss @@ -0,0 +1,279 @@ +#lang scheme + +(require "define.ss" "contract.ss") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; "Missing" Functions +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-if-unbound dict-has-key? + (let () + (with-contract + dict-has-key? + ([dict-has-key? (-> dict? any/c boolean?)]) + (define (dict-has-key? dict key) + (let/ec return + (dict-ref dict key (lambda () (return #f))) + #t))) + dict-has-key?)) + +(define-if-unbound dict-ref! + (let () + (with-contract + dict-ref! + ([dict-ref! (-> (and/c dict? dict-mutable?) + any/c + (or/c (-> any/c) any/c) + any/c)]) + (define (dict-ref! dict key failure) + (dict-ref + dict key + (lambda () + (let* ([value (if (procedure? failure) (failure) failure)]) + (dict-set! dict key value) + value))))) + dict-ref!)) + +(define-if-unbound (dict-empty? dict) + (= (dict-count dict) 0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Constructors +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (empty-dict #:weak? [weak? #f] + #:mutable? [mutable? weak?] + #:compare [compare 'equal]) + (match* [mutable? weak? compare] + ;; Immutable + ([#f #f 'equal] (make-immutable-hash null)) + ([#f #f 'eqv] (make-immutable-hasheqv null)) + ([#f #f 'eq] (make-immutable-hasheq null)) + ;; Mutable + ([#t #f 'equal] (make-hash)) + ([#t #f 'eqv] (make-hasheqv)) + ([#t #f 'eq] (make-hasheq)) + ;; Weak + ([#t #t 'equal] (make-weak-hash)) + ([#t #t 'eqv] (make-weak-hash)) + ([#t #t 'eq] (make-weak-hash)) + ;; Impossible + ([#f #t _] (error 'empty-set "cannot create an immutable weak hash")))) + +(define (make-dict dict + #:weak? [weak? #f] + #:mutable? [mutable? weak?] + #:compare [compare 'equal]) + (let* ([MT (empty-dict #:mutable? mutable? #:weak? weak? #:compare compare)]) + (if mutable? + (begin (dict-union! MT dict) MT) + (dict-union MT dict)))) + +(define (custom-dict equiv? + [hash1 (lambda (x) 0)] + [hash2 (lambda (x) 0)] + #:weak? [weak? #f] + #:mutable? [mutable? weak?]) + (match* [mutable? weak?] + ([#f #f] (make-immutable-custom-hash equiv? hash1 hash2)) + ([#t #f] (make-custom-hash equiv? hash1 hash2)) + ([#t #t] (make-weak-custom-hash equiv? hash1 hash2)) + ([#f #t] (error 'custom-set "cannot create an immutable weak hash")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Ref Wrappers +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (dict-ref/check dict key) + (dict-ref dict key)) + +(define (dict-ref/identity dict key) + (dict-ref dict key (lambda () key))) + +(define (dict-ref/default dict key default) + (dict-ref dict key (lambda () default))) + +(define (dict-ref/failure dict key failure) + (dict-ref dict key (lambda () (failure)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Extra Accessors +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (dict-domain dict) + (for/list ([i (in-dict-keys dict)]) i)) + +(define (dict-range dict) + (for/list ([i (in-dict-values dict)]) i)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Union +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define ((dict-duplicate-error name) key value1 value2) + (error name "duplicate values for key ~e: ~e and ~e" key value1 value2)) + +(define (dict-union + #:combine [combine #f] + #:combine/key [combine/key + (if combine + (lambda (k x y) (combine x y)) + (dict-duplicate-error 'dict-union))] + one . rest) + (for*/fold ([one one]) ([two (in-list rest)] [(k v) (in-dict two)]) + (dict-set one k (if (dict-has-key? one k) + (combine/key k (dict-ref one k) v) + v)))) + +(define (dict-union! + #:combine [combine #f] + #:combine/key [combine/key + (if combine + (lambda (k x y) (combine x y)) + (dict-duplicate-error 'dict-union))] + one . rest) + (for* ([two (in-list rest)] [(k v) (in-dict two)]) + (dict-set! one k (if (dict-has-key? one k) + (combine/key k (dict-ref one k) v) + v)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Property delegation +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (wrapped-dict-property + #:unwrap unwrap + #:wrap [wrap #f] + #:predicate [pred (lambda (x) #t)] + #:mutable? [mutable? #t] + #:functional? [functional? (if wrap #t #f)] + #:remove? [remove? #t]) + (let* ([unwrap (protect-unwrap pred unwrap)] + [wrap (and wrap (protect-wrap pred wrap))]) + (vector (wrapped-ref unwrap) + (and mutable? (wrapped-set! unwrap)) + (and functional? wrap (wrapped-set unwrap wrap)) + (and mutable? remove? (wrapped-remove! unwrap)) + (and functional? remove? wrap (wrapped-remove unwrap wrap)) + (wrapped-count unwrap) + (wrapped-iterate-first unwrap) + (wrapped-iterate-next unwrap) + (wrapped-iterate-key unwrap) + (wrapped-iterate-value unwrap)))) + +(define ((protect-unwrap pred unwrap) op x) + (unless (pred x) + (raise + (make-exn:fail:contract + (format "~a: expected a <~a>, but got: ~e" + op (object-name pred) x) + (current-continuation-marks)))) + (unwrap x)) + +(define ((protect-wrap pred wrap) op x) + (let* ([y (wrap x)]) + (unless (pred y) + (raise + (make-exn:fail:contract + (format "~a: tried to construct a <~a>, but got: ~e" + op (object-name pred) x) + (current-continuation-marks)))) + y)) + +(define (wrapped-ref unwrap) + (case-lambda + [(dict key) (dict-ref (unwrap 'dict-ref dict) key)] + [(dict key fail) (dict-ref (unwrap 'dict-ref dict) key fail)])) + +(define ((wrapped-set! unwrap) dict key value) + (dict-set! (unwrap 'dict-set! dict) key value)) + +(define ((wrapped-set unwrap wrap) dict key value) + (wrap 'dict-set (dict-set (unwrap 'dict-set dict) key value))) + +(define ((wrapped-remove! unwrap) dict key) + (dict-remove! (unwrap 'dict-remove! dict) key)) + +(define ((wrapped-remove unwrap wrap) dict key) + (wrap 'dict-remove (dict-remove (unwrap 'dict-remove dict) key))) + +(define ((wrapped-count unwrap) dict) + (dict-count (unwrap 'dict-count dict))) + +(define ((wrapped-iterate-first unwrap) dict) + (dict-iterate-first (unwrap 'dict-iterate-first dict))) + +(define ((wrapped-iterate-next unwrap) dict pos) + (dict-iterate-next (unwrap 'dict-iterate-next dict) pos)) + +(define ((wrapped-iterate-key unwrap) dict pos) + (dict-iterate-key (unwrap 'dict-iterate-key dict) pos)) + +(define ((wrapped-iterate-value unwrap) dict pos) + (dict-iterate-value (unwrap 'dict-iterate-value dict) pos)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Exports +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide dict/c dict-has-key? dict-ref!) +(provide/contract + [dict-empty? (-> dict? boolean?)] + [empty-dict + (->* [] + [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)] + hash?)] + [make-dict + (->* [dict?] + [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)] + hash?)] + [custom-dict + (->* [(-> any/c any/c any/c)] + [(-> any/c exact-integer?) (-> any/c exact-integer?) + #:mutable? boolean? #:weak? boolean?] + dict?)] + [wrapped-dict-property + (->* [#:unwrap (-> dict? dict?)] + [#:wrap (-> dict? dict?) + #:predicate (-> any/c boolean?) + #:mutable? boolean? + #:remove? boolean? + #:functional? boolean?] + vector?)] + [dict-ref/identity (-> dict? any/c any/c)] + [dict-ref/default (-> dict? any/c any/c any/c)] + [dict-ref/failure (-> dict? any/c (-> any/c) any/c)] + [dict-ref/check + (->d ([table dict?] [key any/c]) () + #:pre-cond (dict-has-key? table key) + [_ any/c])] + [dict-domain (-> dict? list?)] + [dict-range (-> dict? list?)] + [dict-union (->* [(and/c dict? dict-can-functional-set?)] + [#:combine + (-> any/c any/c any/c) + #:combine/key + (-> any/c any/c any/c any/c)] + #:rest (listof dict?) + (and/c dict? dict-can-functional-set?))] + [dict-union! (->* [(and/c dict? dict-mutable?)] + [#:combine + (-> any/c any/c any/c) + #:combine/key + (-> any/c any/c any/c any/c)] + #:rest (listof dict?) + void?)]) diff --git a/collects/unstable/cce/drscheme.ss b/collects/unstable/cce/drscheme.ss new file mode 100644 index 0000000000..eed2fec901 --- /dev/null +++ b/collects/unstable/cce/drscheme.ss @@ -0,0 +1,198 @@ +#lang scheme/gui + +(require drscheme/tool + string-constants + "dict.ss" + (only-in test-engine/scheme-gui make-formatter) + (only-in test-engine/scheme-tests + scheme-test-data test-format test-execute) + (lib "test-display.scm" "test-engine")) + +(provide language-level^ + language-level@) + +(define (read-all-syntax [port (current-input-port)] + [source (object-name port)] + [reader read-syntax]) + (let loop () + (let* ([next (reader source port)]) + (if (eof-object? next) + null + (cons next (loop)))))) + +(define (read-module-body [port (current-input-port)] + [source (object-name port)] + [reader read-syntax] + [path 'scheme] + [name 'program]) + (let*-values ([(line-1 col-1 pos-1) (port-next-location port)] + [(terms) (read-all-syntax port source reader)] + [(line-2 col-2 pos-2) (port-next-location port)] + [(loc) (list source line-1 col-1 pos-1 + (and pos-1 pos-2 (- pos-2 pos-1)))]) + (map (lambda (datum) (datum->syntax #'here datum loc)) + (list `(module ,name ,path + (,(datum->syntax #f '#%module-begin) ,@terms)) + `(require ',name) + `(current-namespace (module->namespace '',name)))))) + +(define-signature language-level^ + (simple-language-level% + make-language-level + language-level-render-mixin + language-level-capability-mixin + language-level-eval-as-module-mixin + language-level-no-executable-mixin + language-level-macro-stepper-mixin + language-level-check-expect-mixin + language-level-metadata-mixin)) + +(define-unit language-level@ + (import drscheme:tool^) + (export language-level^) + + (define (make-language-level + name path + #:number [number (equal-hash-code name)] + #:hierarchy [hierarchy experimental-language-hierarchy] + #:summary [summary name] + #:url [url #f] + #:reader [reader read-syntax] + . mixins) + (let* ([mx-default (drscheme:language:get-default-mixin)] + [mx-custom (apply compose (reverse mixins))]) + (new (mx-custom (mx-default simple-language-level%)) + [module path] + [language-position (append (map car hierarchy) (list name))] + [language-numbers (append (map cdr hierarchy) (list number))] + [one-line-summary summary] + [language-url url] + [reader (make-namespace-syntax-reader reader)]))) + + (define simple-language-level% + (drscheme:language:module-based-language->language-mixin + (drscheme:language:simple-module-based-language->module-based-language-mixin + drscheme:language:simple-module-based-language%))) + + (define (language-level-render-mixin to-sexp show-void?) + (mixin (drscheme:language:language<%>) () + (super-new) + + (define/override (render-value/format value settings port width) + (unless (and (void? value) (not show-void?)) + (super render-value/format (to-sexp value) settings port width))))) + + (define (language-level-capability-mixin dict) + (mixin (drscheme:language:language<%>) () + (super-new) + + (define/augment (capability-value key) + (dict-ref/failure + dict key + (lambda () + (inner (drscheme:language:get-capability-default key) + capability-value key)))))) + + (define language-level-no-executable-mixin + (mixin (drscheme:language:language<%>) () + (super-new) + (inherit get-language-name) + + (define/override (create-executable settings parent filename) + (message-box + "Create Executable: Error" + (format "Sorry, ~a does not support creating executables." + (get-language-name)) + #f '(ok stop))))) + + (define language-level-eval-as-module-mixin + (mixin (drscheme:language:language<%> + drscheme:language:module-based-language<%>) () + (super-new) + + (inherit get-reader get-module) + + (define/override (front-end/complete-program port settings) + (let* ([terms #f]) + (lambda () + ;; On the first run through, initialize the list. + (unless terms + (set! terms (read-module-body port + (object-name port) + (get-reader) + (get-module)))) + ;; Produce each list element in order. + (if (pair? terms) + ;; Produce and remove a list element. + (begin0 (car terms) (set! terms (cdr terms))) + ;; After null, eof forever. + eof)))))) + + (define language-level-macro-stepper-mixin + (language-level-capability-mixin + (make-immutable-hasheq + (list (cons 'macro-stepper:enabled #t))))) + + (define language-level-check-expect-mixin + (mixin (drscheme:language:language<%>) () + (super-new) + (inherit render-value/format) + + (define/augment (capability-value key) + (case key + [(tests:test-menu tests:dock-menu) #t] + [else (inner (drscheme:language:get-capability-default key) + capability-value + key)])) + + (define/override (on-execute settings run-in-user-thread) + (let* ([drscheme-namespace (current-namespace)] + [test-engine-path + ((current-module-name-resolver) + 'test-engine/scheme-tests #f #f)]) + (run-in-user-thread + (lambda () + (namespace-attach-module drscheme-namespace test-engine-path) + (namespace-require test-engine-path) + (scheme-test-data + (list (drscheme:rep:current-rep) + drscheme-eventspace + test-display%)) + (test-execute (get-preference 'tests:enable? (lambda () #t))) + (test-format + (make-formatter + (lambda (v o) (render-value/format v settings o 40)))))) + (super on-execute settings run-in-user-thread))))) + + (define (language-level-metadata-mixin reader-module + meta-lines + meta->settings + settings->meta) + (mixin (drscheme:language:language<%>) () + (inherit default-settings) + (super-new) + + (define/override (get-reader-module) reader-module) + + (define/override (get-metadata modname settings) + (settings->meta modname settings)) + + (define/override (metadata->settings metadata) + (meta->settings metadata (default-settings))) + + (define/override (get-metadata-lines) meta-lines))) + + (define (generic-syntax-reader . args) + (parameterize ([read-accept-reader #t]) + (apply read-syntax args))) + + (define (make-namespace-syntax-reader reader) + (lambda args + (let ([stx (apply reader args)]) + (if (syntax? stx) (namespace-syntax-introduce stx) stx)))) + + (define drscheme-eventspace (current-eventspace)) + + (define experimental-language-hierarchy + (list (cons (string-constant experimental-languages) + 1000)))) diff --git a/collects/unstable/cce/exn.ss b/collects/unstable/cce/exn.ss new file mode 100644 index 0000000000..5340eeccfd --- /dev/null +++ b/collects/unstable/cce/exn.ss @@ -0,0 +1,11 @@ +#lang scheme + +(define-syntax (try stx) + (syntax-case stx () + [(_ e) #'(#%expression e)] + [(_ e0 e ...) + (syntax/loc stx + (with-handlers* ([exn:fail? (lambda (x) (try e ...))]) + (#%expression e0)))])) + +(provide try) diff --git a/collects/unstable/cce/function.ss b/collects/unstable/cce/function.ss new file mode 100644 index 0000000000..2f2163956a --- /dev/null +++ b/collects/unstable/cce/function.ss @@ -0,0 +1,382 @@ +#lang scheme/base +(require scheme/dict scheme/match scheme/function "define.ss" + (for-syntax scheme/base scheme/list)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; HIGHER ORDER TOOLS +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Automatic case-lambda repetition +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-for-syntax (split-syntax-at orig stx id) + (let loop ([found #f] + [seen null] + [stx stx]) + (syntax-case stx [] + [(head . tail) + (and (identifier? #'head) + (free-identifier=? #'head id)) + (if found + (raise-syntax-error + #f + (format "duplicate occurrence of ~a" (syntax-e id)) + orig + #'head) + (loop (list (reverse seen) #'head #'tail) + (cons #'head seen) + #'tail))] + [(head . tail) (loop found (cons #'head seen) #'tail)] + [_ found]))) + +(define-for-syntax (expand-ellipsis-clause stx pattern expr) + (cond + [(split-syntax-at stx pattern #'(... ...)) + => + (lambda (found) + (syntax-case found [...] + [([pre ... repeat] (... ...) [count post ... . tail]) + (and (identifier? #'repeat) + (exact-nonnegative-integer? (syntax-e #'count))) + (build-list + (add1 (syntax-e #'count)) + (lambda (i) + (with-syntax ([(var ...) + (generate-temporaries + (build-list i (lambda (j) #'repeat)))] + [body expr]) + (list + (syntax/loc pattern (pre ... var ... post ... . tail)) + (syntax/loc expr + (let-syntax ([the-body + (lambda _ + (with-syntax ([(repeat (... ...)) #'(var ...)]) + #'body))]) + the-body))))))] + [(pre mid post) + (raise-syntax-error + #f + "expected ellipsis between identifier and natural number literal" + stx + #'mid)]))] + [else (list (list pattern expr))])) + +(define-syntax (case-lambda* stx) + (syntax-case stx [] + [(_ [pattern body] ...) + (with-syntax ([([pattern body] ...) + (append-map + (lambda (p e) (expand-ellipsis-clause stx p e)) + (syntax->list #'(pattern ...)) + (syntax->list #'(body ...)))]) + (syntax/loc stx + (case-lambda [pattern body] ...)))])) + +(define-syntax (make-intermediate-procedure stx) + (syntax-case stx [quote] + [(_ (quote name) positional-clause ... #:keyword keyword-clause) + (syntax/loc stx + (make-keyword-procedure + (let* ([name (case-lambda keyword-clause)]) name) + (let* ([name (case-lambda* positional-clause ...)]) name)))])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Degenerate Functions +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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 ...) + (syntax/loc stx + (make-keyword-thunk (lambda () body ...)))])) + +(define (make-keyword-thunk f) + (make-intermediate-procedure + 'thunk-function + [(x ... 8) (f)] + [xs (f)] + #:keyword + [(ks vs . xs) (f)])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Higher-Order Boolean Operations +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define conjoin + (case-lambda* + [(f ... 8) + (make-intermediate-procedure + 'conjoined + [(x (... ...) 8) (and (f x (... ...)) ...)] + [xs (and (apply f xs) ...)] + #:keyword + [(keys vals . args) + (and (keyword-apply f keys vals args) ...)])] + [fs + (make-intermediate-procedure + 'conjoined + [(x ... 8) (andmap (lambda (f) (f x ...)) fs)] + [xs (andmap (lambda (f) (apply f xs)) fs)] + #:keyword + [(keys vals . args) + (andmap (lambda (f) (keyword-apply f keys vals args)) fs)])])) + +(define disjoin + (case-lambda* + [(f ... 8) + (make-intermediate-procedure + 'disjoined + [(x (... ...) 8) (or (f x (... ...)) ...)] + [xs (or (apply f xs) ...)] + #:keyword + [(keys vals . args) + (or (keyword-apply f keys vals args) ...)])] + [fs + (make-intermediate-procedure + 'disjoined + [(x ... 8) (ormap (lambda (f) (f x ...)) fs)] + [xs (ormap (lambda (f) (apply f xs)) fs)] + #:keyword + [(keys vals . args) + (ormap (lambda (f) (keyword-apply f keys vals args)) fs)])])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Function Invocation (partial or indirect) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax-rule (cons2 one two rest) + (let*-values ([(ones twos) rest]) + (values (cons one ones) (cons two twos)))) + +(define merge-keywords + (match-lambda* + [(or (list _ '() '() keys vals) + (list _ keys vals '() '())) + (values keys vals)] + [(list name + (and keys1* (cons key1 keys1)) (and vals1* (cons val1 vals1)) + (and keys2* (cons key2 keys2)) (and vals2* (cons val2 vals2))) + (cond + [(keywordinterface text-field%)] [] + + (inherit get-editor) + + (define/override (set-value str) + (send (get-editor) lock #f) + (super set-value str) + (send (get-editor) lock #t)) + + (super-new) + + (init [undo-history 0]) + + (send (get-editor) lock #t) + (send (get-editor) set-max-undo-history undo-history))) + +(define locked-text-field% + (locked-text-field-mixin text-field%)) + +(define locked-combo-field% + (locked-text-field-mixin combo-field%)) + + +;; ====================================================================== +;; +;; UNION PANEL CLASS / MIXIN +;; +;; ====================================================================== + +(define union-container-mixin + (mixin [area-container<%>] [] + + (super-new) + + (inherit get-children get-alignment) + + (define/public (choose child) + (for ([child* (get-children)]) + (send child* show (eq? child* child)))) + + (define/override (container-size info) + (match info + [(list (list w h _ _) ...) + (values (apply max 0 w) + (apply max 0 h))])) + + (define/override (place-children info w0 h0) + (let*-values ([(ha va) (get-alignment)] + [(hp) (horiz->place ha)] + [(vp) (vert->place va)]) + (map (lambda (child) (place-child hp vp w0 h0 child)) info))) + + (define/private (place-child hp vp w0 h0 child) + (match child + [(list cw ch sw sh) + (let*-values ([(x w) (place-dim hp w0 cw sw)] + [(y h) (place-dim vp h0 ch sh)]) + (list x y w h))])) + + (define/private (place-dim p maximum minimum stretch?) + (match (list p stretch?) + [(list _ #t) (values 0 maximum)] + [(list 'min #f) (values 0 minimum)] + [(list 'mid #f) (values (floor (/ (- maximum minimum) 2)) minimum)] + [(list 'max #f) (values (- maximum minimum) minimum)])) + + (define/private horiz->place + (match-lambda ['left 'min] ['center 'mid] ['right 'max])) + + (define/private vert->place + (match-lambda ['top 'min] ['center 'mid] ['bottom 'max])))) + +(define union-pane% (union-container-mixin pane%)) +(define union-panel% (union-container-mixin panel%)) + diff --git a/collects/unstable/cce/hash.ss b/collects/unstable/cce/hash.ss new file mode 100644 index 0000000000..48d215373d --- /dev/null +++ b/collects/unstable/cce/hash.ss @@ -0,0 +1,136 @@ +#lang scheme + +(require "define.ss" (for-syntax syntax/parse)) + +(define-if-unbound (hash-has-key? table key) + (let/ec return + (hash-ref table key (lambda () (return #f))) + #t)) + +(define-if-unbound (hash-equal? table) + (and (hash? table) + (not (hash-eq? table)) + (not (hash-eqv? table)))) + +(define (hash-ref/check table key) + (hash-ref table key)) + +(define (hash-ref/identity table key) + (hash-ref table key (lambda () key))) + +(define (hash-ref/default table key default) + (hash-ref table key (lambda () default))) + +(define (hash-ref/failure table key failure) + (hash-ref table key (lambda () (failure)))) + +(define (hash-domain table) + (for/list ([i (in-hash-keys table)]) i)) + +(define (hash-range table) + (for/list ([i (in-hash-values table)]) i)) + +(define ((hash-duplicate-error name) key value1 value2) + (error name "duplicate values for key ~e: ~e and ~e" key value1 value2)) + +(define (hash-union + #:combine [combine #f] + #:combine/key [combine/key + (if combine + (lambda (k x y) (combine x y)) + (hash-duplicate-error 'hash-union))] + one . rest) + (for*/fold ([one one]) ([two (in-list rest)] [(k v) (in-hash two)]) + (hash-set one k (if (hash-has-key? one k) + (combine/key k (hash-ref one k) v) + v)))) + +(define (hash-union! + #:combine [combine #f] + #:combine/key [combine/key + (if combine + (lambda (k x y) (combine x y)) + (hash-duplicate-error 'hash-union))] + one . rest) + (for* ([two (in-list rest)] [(k v) (in-hash two)]) + (hash-set! one k (if (hash-has-key? one k) + (combine/key k (hash-ref one k) v) + v)))) + +(define-syntaxes [ hash hash! ] + (let () + + (define-syntax-class key/value + #:attributes [key value] + (pattern [key:expr value:expr])) + + (define-splicing-syntax-class immutable-hash-type + #:attributes [constructor] + (pattern (~seq #:eqv) #:attr constructor #'make-immutable-hasheqv) + (pattern (~seq #:eq) #:attr constructor #'make-immutable-hasheq) + (pattern (~seq (~optional #:equal)) + #:attr constructor #'make-immutable-hash)) + + (define-splicing-syntax-class mutable-hash-type + #:attributes [constructor] + (pattern (~seq #:base constructor:expr)) + (pattern (~seq (~or (~once #:eqv) (~once #:weak)) ...) + #:attr constructor #'(make-weak-hasheqv)) + (pattern (~seq (~or (~once #:eq) (~once #:weak)) ...) + #:attr constructor #'(make-weak-hasheq)) + (pattern (~seq (~or (~optional #:equal) (~once #:weak)) ...) + #:attr constructor #'(make-weak-hash)) + (pattern (~seq #:eqv) #:attr constructor #'(make-hasheqv)) + (pattern (~seq #:eq) #:attr constructor #'(make-hasheq)) + (pattern (~seq (~optional #:equal)) #:attr constructor #'(make-hash))) + + (define (parse-hash stx) + (syntax-parse stx + [(_ (~seq type:immutable-hash-type) elem:key/value ...) + (syntax/loc stx + (type.constructor (list (cons elem.key elem.value) ...)))] + [(_ #:base h:expr elem:key/value ...) + (syntax/loc stx + (for/fold + ([table h]) + ([key (in-list (list elem.key ...))] + [value (in-list (list elem.value ...))]) + (hash-set table key value)))])) + + (define (parse-hash! stx) + (syntax-parse stx + [(_ (~seq type:mutable-hash-type) elem:key/value ...) + (syntax/loc stx + (let ([table type.constructor]) + (for ([key (in-list (list elem.key ...))] + [value (in-list (list elem.value ...))]) + (hash-set! table key value)) + table))])) + + (values parse-hash parse-hash!))) + +(provide hash hash! hash-has-key? hash-equal?) +(provide/contract + [hash-ref/identity (-> hash? any/c any/c)] + [hash-ref/default (-> hash? any/c any/c any/c)] + [hash-ref/failure (-> hash? any/c (-> any/c) any/c)] + [hash-ref/check + (->d ([table hash?] [key any/c]) () + #:pre-cond (hash-has-key? table key) + [_ any/c])] + [hash-domain (-> hash? list?)] + [hash-range (-> hash? list?)] + [hash-union (->* [(and/c hash? immutable?)] + [#:combine + (-> any/c any/c any/c) + #:combine/key + (-> any/c any/c any/c any/c)] + #:rest (listof hash?) + (and/c hash? immutable?))] + [hash-union! (->* [(and/c hash? (not/c immutable?))] + [#:combine + (-> any/c any/c any/c) + #:combine/key + (-> any/c any/c any/c any/c)] + #:rest (listof hash?) + void?)]) diff --git a/collects/unstable/cce/info.ss b/collects/unstable/cce/info.ss new file mode 100644 index 0000000000..b1aa89f431 --- /dev/null +++ b/collects/unstable/cce/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define name "Carl Eastlund's Scheme Utilities") diff --git a/collects/unstable/cce/match.ss b/collects/unstable/cce/match.ss new file mode 100644 index 0000000000..1f64358ec0 --- /dev/null +++ b/collects/unstable/cce/match.ss @@ -0,0 +1,127 @@ +#lang scheme +(require + (for-syntax scheme/match + scheme/struct-info + "define.ss" + "function.ss" + "syntax.ss")) + +(define-syntax-rule (match? e p ...) + (match e [p #t] ... [_ #f])) + +(define-syntax (define-struct-pattern stx) + (parameterize ([current-syntax stx]) + (syntax-case stx () + [(_ pattern-name struct-name) + (block + + (define pattern-id #'pattern-name) + (define struct-id #'struct-name) + + (unless (identifier? pattern-id) + (syntax-error pattern-id "expected an identifier")) + + (unless (identifier? struct-id) + (syntax-error struct-id "expected an identifier")) + + (define struct-info (syntax-local-value struct-id)) + + (unless (struct-info? struct-info) + (syntax-error struct-id "expected a struct name")) + + (match (extract-struct-info struct-info) + [(list type-id + constructor-id + predicate-id + accessor-ids + mutator-ids + super-id) + (with-syntax ([make constructor-id] + [(p ...) (generate-temporaries accessor-ids)]) + (syntax/loc stx + (define-match-expander pattern-name + (syntax-rules () + [(_ p ...) (struct struct-name [p ...])]) + (redirect-transformer #'make))))]))]))) + +(define-for-syntax (get-struct-info id) + (block + + (define (fail) + (syntax-error id "expected a structure name")) + + (define value + (syntax-local-value id fail)) + + (unless (struct-info? value) (fail)) + + (extract-struct-info value))) + +(define-for-syntax (struct-match-expander stx) + (parameterize ([current-syntax stx]) + (syntax-case stx () + [(_ s f ...) + (match (get-struct-info #'s) + [(list _ + _ + (? identifier? pred) + (list-rest (? identifier? rev-gets) ... (or (list) (list #f))) + _ + _) + (let* ([n-patterns (length (syntax-list f ...))] + [n-fields (length rev-gets)]) + (unless (= n-patterns n-fields) + (syntax-error #'s + "got ~a patterns for ~a fields of ~a" + n-patterns n-fields (syntax-e #'s)))) + (with-syntax ([pred? pred] + [(get ...) (reverse rev-gets)]) + (syntax/loc stx + (and (? pred?) (app get f) ...)))] + [_ + (syntax-error + #'s + "expected a structure name with predicate and ~a fields; got ~a" + (length (syntax-list f ...)) + (syntax-e #'s))])]))) + +(define-for-syntax (struct-make-expander stx) + (parameterize ([current-syntax stx]) + (syntax-case stx () + [(_ s f ...) + (match (get-struct-info #'s) + [(list _ + (? identifier? make) + _ + rev-gets + _ + _) + (match rev-gets + [(list (? identifier?) ...) + (let* ([n-fields (length rev-gets)] + [n-exprs (length (syntax-list f ...))]) + (unless (= n-exprs n-fields) + (syntax-error + #'s + "got ~a arguments for ~a fields in structure ~a" + n-exprs n-fields (syntax-e #'s))))] + [_ (void)]) + (with-syntax ([mk make]) + (syntax/loc stx + (mk f ...)))] + [_ + (syntax-error + #'s + "expected a structure name with constructor; got ~a" + (syntax-e #'s))])]))) + +(define-match-expander $ + ;; define-match-expander is STUPIDLY non-uniform about variable expressions + (identity struct-match-expander) + (identity struct-make-expander)) + +(define-match-expander as + (syntax-rules () + [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)])) + +(provide match? define-struct-pattern $ as) diff --git a/collects/unstable/cce/planet.ss b/collects/unstable/cce/planet.ss new file mode 100644 index 0000000000..68bdad072a --- /dev/null +++ b/collects/unstable/cce/planet.ss @@ -0,0 +1,26 @@ +#lang scheme + +(require (for-syntax "syntax.ss") + "syntax.ss" + "require-provide.ss") + +(define-syntax (this-package-version-symbol stx) + (syntax-case stx () + [(tpvi) + (quasisyntax/loc stx + '#,(syntax-source-planet-package-symbol stx #f))] + [(tpvi name) + (identifier? #'name) + (quasisyntax/loc stx + '#,(syntax-source-planet-package-symbol stx #'name))])) + +(provide this-package-version-symbol + this-package-in + define-planet-package + make-planet-path + syntax-source-planet-package + syntax-source-planet-package-owner + syntax-source-planet-package-name + syntax-source-planet-package-major + syntax-source-planet-package-minor + syntax-source-planet-package-symbol) diff --git a/collects/unstable/cce/port.ss b/collects/unstable/cce/port.ss new file mode 100644 index 0000000000..c4f0a7102e --- /dev/null +++ b/collects/unstable/cce/port.ss @@ -0,0 +1,56 @@ +#lang scheme + +(require "function.ss" "syntax.ss" "private/define-core.ss") + +(define-if-unbound (eprintf fmt . args) + (apply fprintf (current-error-port) fmt args)) + +(define buffer (make-bytes 1024)) + +(define (read-available-bytes [port (current-input-port)]) + (read-available-bytes/offset port 0)) + +(define (read-available-bytes/offset port offset) + (let* ([result (read-bytes-avail!* buffer port offset)]) + (if (eof-object? result) + (if (zero? offset) result (subbytes buffer 0 offset)) + (let* ([new-offset (+ offset result)]) + (if (= new-offset (bytes-length buffer)) + (begin (set! buffer (bytes-append buffer buffer)) + (read-available-bytes/offset port new-offset)) + (subbytes buffer 0 new-offset)))))) + +(define (port->srcloc port [source (object-name port)] [span 0]) + (let*-values ([(line col pos) (port-next-location port)]) + (make-srcloc source line col pos span))) + +(define read-all + (case-lambda + [() (read-all read)] + [(reader) + (let loop () + (match (reader) + [(? eof-object?) null] + [term (cons term (loop))]))] + [(reader port) + (parameterize ([current-input-port port]) + (read-all reader))])) + +(define read-all-syntax + (case-lambda + [() (read-all-syntax read-syntax)] + [(reader) (read-all-syntax reader (current-input-port))] + [(reader port) + (define start (port->srcloc port)) + (define terms (read-all reader port)) + (define end (port->srcloc port)) + (to-syntax #:src (src->list start end) terms)])) + +(provide eprintf) +(provide/contract + [read-all (->* [] [(-> any/c) input-port?] list?)] + [read-all-syntax + (->* [] [(-> (or/c syntax? eof-object?)) input-port?] + (syntax/c list?))] + [read-available-bytes (->* [] [input-port?] (or/c bytes? eof-object?))] + [port->srcloc (->* [port?] [any/c exact-nonnegative-integer?] srcloc?)]) diff --git a/collects/unstable/cce/private/define-core.ss b/collects/unstable/cce/private/define-core.ss new file mode 100644 index 0000000000..e980380469 --- /dev/null +++ b/collects/unstable/cce/private/define-core.ss @@ -0,0 +1,68 @@ +#lang scheme/base + +(require (for-syntax scheme/base scheme/list "syntax-core.ss")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Definition Generalization +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide define-single-definition) + +(define-syntax-rule (define-single-definition define-one define-many) + (define-syntax define-one + (syntax-rules [] + [(_ (head . args) . body) (define-one head (lambda args . body))] + [(_ name expr) (define-many [name] expr)]))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Potentially Redundant Bindings +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide define-if-unbound + define-values-if-unbound + define-syntaxes-if-unbound + define-syntax-if-unbound) + +(define-syntax (define-many-if-unbound stx) + (syntax-case stx [] + [(_ def [name ...] expr) + (let* ([ids (syntax->list #'(name ...))]) + (for ([bad (in-list ids)] #:when (not (identifier? bad))) + (syntax-error bad "expected an identifier")) + (let*-values ([(bound unbound) (partition identifier-binding ids)]) + (cond + [(null? bound) (syntax/loc stx (def [name ...] expr))] + [(null? unbound) (syntax/loc stx (def [] (values)))] + [else (syntax-error + stx + "conflicting definitions for ~s; none for ~s" + (map syntax-e bound) + (map syntax-e unbound))])))])) + +(define-syntax-rule (define-values-if-unbound [name ...] expr) + (define-many-if-unbound define-values [name ...] expr)) + +(define-single-definition define-if-unbound define-values-if-unbound) + +(define-syntax-rule (define-syntaxes-if-unbound [name ...] expr) + (define-many-if-unbound define-syntaxes [name ...] expr)) + +(define-single-definition define-syntax-if-unbound define-syntaxes-if-unbound) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Trampoline Expansion +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide #%trampoline) + +(define-syntax (#%trampoline stx) + (syntax-case stx () + [(_ thunk) + (procedure? (syntax-e #'thunk)) + (#%app (syntax-e #'thunk))])) diff --git a/collects/unstable/cce/private/syntax-core.ss b/collects/unstable/cce/private/syntax-core.ss new file mode 100644 index 0000000000..c549e94977 --- /dev/null +++ b/collects/unstable/cce/private/syntax-core.ss @@ -0,0 +1,160 @@ +#lang scheme/base + +(require scheme/contract + scheme/match + (only-in unstable/syntax with-syntax*) + "../text.ss" + (for-syntax scheme/base)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Source Locations +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide src-known? src->srcloc src->list src->vector src->syntax) + +(define srcloc->list + (match-lambda + [(struct srcloc [src line col pos span]) + (list src line col pos span)])) + +(define srcloc->vector + (match-lambda + [(struct srcloc [src line col pos span]) + (vector src line col pos span)])) + +(define (srcloc->syntax loc [v null]) + (datum->syntax #f v (srcloc->list loc))) + +(define (src->srcloc . locs) (combine-srclocs (map convert-loc locs))) + +(define src->list (compose srcloc->list src->srcloc)) +(define src->vector (compose srcloc->vector src->srcloc)) +(define src->syntax (compose srcloc->syntax src->srcloc)) + +(define (src-known? x) + (not (equal? (convert-loc x) (convert-loc #f)))) + +(define convert-loc + (match-lambda + [(? srcloc? loc) loc] + [(or (list src line col pos span) + (vector src line col pos span) + (and #f src line col pos span) + (and (? syntax?) + (app syntax-source src) + (app syntax-line line) + (app syntax-column col) + (app syntax-position pos) + (app syntax-span span))) + (make-srcloc src line col pos span)])) + +(define combine-srclocs + (match-lambda + ;; Two locations with matching source + [(list (struct srcloc [src line1 col1 pos1 span1]) + (struct srcloc [src line2 col2 pos2 span2]) + locs ...) + (let* ([line (and line1 line2 (min line1 line2))] + [col (and line col1 col2 + (cond [(< line1 line2) col1] + [(= line1 line2) (min col1 col2)] + [(> line1 line2) col2]))] + [pos (and pos1 pos2 (min pos1 pos2))] + [span (and pos span1 span2 + (- (max (+ pos1 span1) (+ pos2 span2)) pos))]) + (combine-srclocs (cons (make-srcloc src line col pos span) locs)))] + ;; One location + [(list loc) loc] + ;; No locations, or mismatched sources + [_ (make-srcloc #f #f #f #f #f)])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Syntax Conversions +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide syntax-map to-syntax to-datum) + +(define (syntax-map f stx) + (map f (syntax->list stx))) + +(define (to-syntax datum + #:stx [stx #f] + #:src [src stx] + #:ctxt [ctxt stx] + #:prop [prop stx] + #:cert [cert stx]) + (datum->syntax ctxt + datum + (if (srcloc? src) (srcloc->list src) src) + prop + cert)) + +(define (to-datum v) + (if (syntax? v) + (syntax->datum v) + v)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Pattern Bindings +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide with-syntax* syntax-list) + +(define-syntax-rule (syntax-list template ...) + (syntax->list (syntax (template ...)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Syntax Errors +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide current-syntax syntax-error) + +(define current-syntax (make-parameter #f)) + +(define (syntax-error #:name [name #f] stx msg . args) + (let* ([cur (current-syntax)] + [one (if cur cur stx)] + [two (if cur stx #f)] + [sym (if name (text->symbol name) #f)] + [str (apply format msg args)]) + (raise-syntax-error sym str one two))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Syntax Contracts +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide syntax-datum/c syntax-listof/c syntax-list/c) + +(define (syntax-datum/c datum) + (let* ([datum/c (coerce-contract datum datum)]) + (flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c) + (lambda (v) + (and (syntax? v) + ((flat-contract-predicate datum/c) + (syntax->datum v))))))) + +(define (syntax-listof/c elem) + (let* ([elem/c (coerce-contract elem elem)]) + (flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c) + (lambda (v) + (and (syntax? v) + ((flat-contract-predicate (listof elem/c)) + (syntax->list v))))))) + +(define (syntax-list/c . elems) + (let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)]) + (flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs) + (lambda (v) + (and (syntax? v) + ((flat-contract-predicate (apply list/c elem/cs)) + (syntax->list v))))))) diff --git a/collects/unstable/cce/queue.ss b/collects/unstable/cce/queue.ss new file mode 100644 index 0000000000..f749017e96 --- /dev/null +++ b/collects/unstable/cce/queue.ss @@ -0,0 +1,58 @@ +#lang scheme + +;; A Queue is a circularly linked list of queue structures. +;; The head of the circle is identified by the distinguished head value. +;; The top of the queue (front of the line) is to the right of the head. +;; The bottom of the queue (back of the line) is to the left of the head. +(define-struct queue (value left right) #:mutable) + +(define head (gensym 'queue-head)) + +(define (empty-queue) + (let* ([q (make-queue head #f #f)]) + (set-queue-left! q q) + (set-queue-right! q q) + q)) + +(define (queue-head? q) + (eq? (queue-value q) head)) + +(define (head-queue? v) + (and (queue? v) (queue-head? v))) + +(define (queue-empty? q) + (and (queue-head? q) (queue-head? (queue-right q)))) + +(define (nonempty-queue? v) + (and (queue? v) + (queue-head? v) + (queue? (queue-right v)) + (not (queue-head? (queue-right v))))) + +(define (enqueue! q v) + (let* ([bot (queue-left q)] + [new (make-queue v bot q)]) + (set-queue-left! q new) + (set-queue-right! bot new))) + +(define (dequeue! q) + (let* ([old (queue-right q)] + [top (queue-right old)]) + (set-queue-right! q top) + (set-queue-left! top q) + (queue-value old))) + +(define queue/c + (flat-named-contract "queue" head-queue?)) + +(define nonempty-queue/c + (flat-named-contract "nonempty-queue" nonempty-queue?)) + +(provide/contract + [queue/c flat-contract?] + [nonempty-queue/c flat-contract?] + [rename head-queue? queue? (-> any/c boolean?)] + [rename empty-queue make-queue (-> queue/c)] + [queue-empty? (-> queue/c boolean?)] + [enqueue! (-> queue/c any/c void?)] + [dequeue! (-> nonempty-queue/c any/c)]) diff --git a/collects/unstable/cce/reference/class.scrbl b/collects/unstable/cce/reference/class.scrbl new file mode 100644 index 0000000000..d17ce1e149 --- /dev/null +++ b/collects/unstable/cce/reference/class.scrbl @@ -0,0 +1,90 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/class)) + +@title[#:style 'quiet #:tag "cce-class"]{Classes and Objects} + +@defmodule[unstable/cce/class] + +This module provides tools for classes, objects, and mixins. + +@section{Predicates and Contracts} + +@defthing[class-or-interface/c flat-contract?]{ + +Recognizes classes and interfaces. + +} + +@defproc[(object-provides/c [spec class-or-interface/c] ...) flat-contract?]{ + +Recognizes objects which are instances of all the given classes and interfaces. + +} + +@defproc[(class-provides/c [spec class-or-interface/c] ...) flat-contract?]{ + +Recognizes classes which are subclasses (not strictly) and implementations, +respectively, of all the given classes and interfaces. + +} + +@defform[(mixin-provides/c [super-expr ...] [sub-expr ...])]{ + +Function contract for a mixin whose argument is the parent class @var[c%] +matching @scheme[(class-provides/c super-expr ...)] and whose result matches +@scheme[(class-provides/c #,(var c%) sub-expr ...)]. + +} + +@section{Mixins} + +@defproc[(ensure-interface [i<%> interface?] + [mx (mixin-provides/c [] [i<%>])] + [c% class?]) + (class-provides/c c% i<%>)]{ + +Returns @scheme[c%] if it implements @scheme[i<%>]; otherwise, returns +@scheme[(mx c%)]. + +} + +@section{Methods} + +@defform[(send+ obj [message arg ...] ...)]{ + +Sends each message (with arguments) to @scheme[obj], then returns @scheme[obj]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/class) +(define c% + (class object% + (super-new) + (define/public (say msg) (printf "~a!\n" msg)))) +(send+ (new c%) [say 'Hello] [say 'Good-bye]) +] + +} + +@defform[(send-each objs message arg ...)]{ + +Sends the message to each object in the list @scheme[objs], returning +@scheme[(void)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/class) +(define c% + (class object% + (super-new) + (init-field msg) + (define/public (say to) (printf "~a, ~a!\n" msg to)))) +(send-each + (list (new c% [msg 'Hello]) + (new c% [msg 'Good-bye])) + say 'World) +] + +} diff --git a/collects/unstable/cce/reference/contract.scrbl b/collects/unstable/cce/reference/contract.scrbl new file mode 100644 index 0000000000..773d87f846 --- /dev/null +++ b/collects/unstable/cce/reference/contract.scrbl @@ -0,0 +1,131 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/contract)) + +@title[#:style 'quiet #:tag "cce-contract"]{Contracts} + +@defmodule[unstable/cce/contract] + +This module provides useful contracts and contract constructors. + +@section{Flat Contracts} + +@defthing[nat/c flat-contract?]{ + +This contract recognizes natural numbers that satisfy +@scheme[exact-nonnegative-integer?]. + +} + +@defthing[pos/c flat-contract?]{ + +This contract recognizes positive integers that satisfy +@scheme[exact-positive-integer?]. + +} + +@defthing[truth/c flat-contract?]{ + +This contract recognizes Scheme truth values, i.e., any value, but with a more +informative name and description. Use it in negative positions for arguments +that accept arbitrary truth values that may not be booleans. + +} + +@section{Higher-Order Contracts} + +@deftogether[( +@defthing[thunk/c contract?] +@defthing[unary/c contract?] +@defthing[binary/c contract?] +)]{ + +These contracts recognize functions that accept 0, 1, or 2 arguments, +respectively, and produce a single result. + +} + +@deftogether[( +@defthing[predicate/c contract?] +@defthing[predicate-like/c contract?] +)]{ + +These contracts recognize predicates: functions of a single argument that +produce a boolean result. + +The first constrains its output to satisfy @scheme[boolean?]. Use +@scheme[predicate/c] in positive position for predicates that guarantee a result +of @scheme[#t] or @scheme[#f]. + +The second constrains its output to satisfy @scheme[truth/c]. Use +@scheme[predicate-like/c] in negative position for predicates passed as +arguments that may return arbitrary values as truth values. + +} + +@deftogether[( +@defthing[comparison/c contract?] +@defthing[comparison-like/c contract?] +)]{ + +These contracts recognize comparisons: functions of two arguments that +produce a boolean result. + +The first constrains its output to satisfy @scheme[boolean?]. Use +@scheme[comparison/c] in positive position for comparisons that guarantee a +result of @scheme[#t] or @scheme[#f]. + +The second constrains its output to satisfy @scheme[truth/c]. Use +@scheme[comparison-like/c] in negative position for comparisons passed as +arguments that may return arbitrary values as truth values. + +} + +@defproc[(sequence/c [elem/c contract?] ...) contract?]{ + +Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequence}, +obligating it to produce as many values as there are @scheme[elem/c] contracts, +and obligating each value to satisfy the corresponding @scheme[elem/c]. The +result is not guaranteed to be the same kind of sequence as the original value; +for instance, a wrapped list is not guaranteed to satisfy @scheme[list?]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/contract) +(define/contract predicates + (sequence/c (-> any/c boolean?)) + (list integer? string->symbol)) +(for ([P predicates]) + (printf "~s\n" (P "cat"))) +] + +} + +@defproc[(dict/c [key/c contract?] [value/c contract?]) contract?]{ + +Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{dictionary}, +obligating its keys to satisfy @scheme[key/c] and their corresponding values to +satisfy @scheme[value/c]. The result is not guaranteed to be the same kind of +dictionary as the original value; for instance, a wrapped hash table is not +guaranteed to satisfy @scheme[hash?]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/contract) +(define/contract table + (dict/c symbol? string?) + (make-immutable-hash (list (cons 'A "A") (cons 'B 2) (cons 3 "C")))) +(dict-ref table 'A) +(dict-ref table 'B) +(dict-ref table 3) +] + +@emph{Warning:} Bear in mind that key and value contracts are re-wrapped on +every dictionary operation, and dictionaries wrapped in @scheme[dict/c] multiple +times will perform the checks as many times for each operation. Especially for +immutable dictionaries (which may be passed through a constructor that involves +@scheme[dict/c] on each update), contract-wrapped dictionaries may be much less +efficient than the original dictionaries. + +} diff --git a/collects/unstable/cce/reference/debug.scrbl b/collects/unstable/cce/reference/debug.scrbl new file mode 100644 index 0000000000..42e538f606 --- /dev/null +++ b/collects/unstable/cce/reference/debug.scrbl @@ -0,0 +1,71 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/debug unstable/syntax)) + +@title[#:style 'quiet #:tag "cce-debug"]{Debugging} + +@defmodule[unstable/cce/debug] + +This module provides macros and functions for printing out debugging +information. + +@defform[(debug expr)]{ + +Logs debugging information before and after the evaluation of expression +@scheme[expr]. + +} + +@defform/subs[ +(with-debugging options ... expr) +([options (code:line #:name name-expr) + (code:line #:source srcloc-expr)]) +]{ + +Logs debugging information like @scheme[debug], with the option of explicitly +overriding the name and source location information for the expression. + +} + +@defproc[(dprintf [fmt string?] [arg any/c] ...) void?]{ + +Constructs a message in the same manner as @scheme[format], and logs it at the +debugging priority (like @scheme[log-debug]). + +} + +@deftogether[( +@defform[(begin/debug expr ...)] +@defform*[[(define/debug id expr) + (define/debug (head args) body ...+)]] +@defform*[[(define/private/debug id expr) + (define/private/debug (head args) body ...+)]] +@defform*[[(define/public/debug id expr) + (define/public/debug (head args) body ...+)]] +@defform*[[(define/override/debug id expr) + (define/override/debug (head args) body ...+)]] +@defform*[[(define/augment/debug id expr) + (define/augment/debug (head args) body ...+)]] +@defform*[[(let/debug ([lhs-id rhs-expr] ...) body ...+) + (let/debug loop-id ([lhs-id rhs-expr] ...) body ...+)]] +@defform[(let*/debug ([lhs-id rhs-expr] ...) body ...+)] +@defform[(letrec/debug ([lhs-id rhs-expr] ...) body ...+)] +@defform[(let-values/debug ([(lhs-id ...) rhs-expr] ...) body ...+)] +@defform[(let*-values/debug ([(lhs-id ...) rhs-expr] ...) body ...+)] +@defform[(letrec-values/debug ([(lhs-id ...) rhs-expr] ...) body ...+)] +@defform[(with-syntax/debug ([pattern stx-expr] ...) body ...+)] +@defform[(with-syntax*/debug ([pattern stx-expr] ...) body ...+)] +@defform[(parameterize/debug ([param-expr value-expr] ...) body ...+)] +)]{ + +These macros add logging based on @scheme[with-debugging] to the evaluation of +expressions in @scheme[begin], @scheme[define], @scheme[define/private], +@scheme[define/public], @scheme[define/override], @scheme[define/augment], +@scheme[let], @scheme[let*], @scheme[letrec], @scheme[let-values], +@scheme[let*-values], @scheme[letrec-values], @scheme[with-syntax], +@scheme[with-syntax*], and @scheme[parameterize]. + +} diff --git a/collects/unstable/cce/reference/define.scrbl b/collects/unstable/cce/reference/define.scrbl new file mode 100644 index 0000000000..01abf1f079 --- /dev/null +++ b/collects/unstable/cce/reference/define.scrbl @@ -0,0 +1,176 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/define)) + +@title[#:style 'quiet #:tag "cce-define"]{Definitions} + +@defmodule[unstable/cce/define] + +This module provides macros for creating and manipulating definitions. + +@section{Interleaving Definitions and Expressions} + +@defform[(block def-or-expr ...)]{ + +This expression establishes a lexically scoped block (i.e. an internal +definition context) in which definitions and expressions may be interleaved. +Its result is that of the last term (after @scheme[begin]-splicing), executed in +tail position, if the term is an expression; if there are no terms, or the last +term is a definition, its result is @scheme[(void)]. + +This form is equivalent to @scheme[(begin-with-definitions def-or-expr ...)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/define) +(define (intersection list-one list-two) + (block + + (define hash-one (make-hash)) + (for ([x (in-list list-one)]) + (hash-set! hash-one x #t)) + + (define hash-two (make-hash)) + (for ([x (in-list list-two)]) + (hash-set! hash-two x #t)) + + (for/list ([x (in-hash-keys hash-one)] + #:when (hash-has-key? hash-two x)) + x))) + +(intersection (list 1 2 3) (list 2 3 4)) +] + +} + +@section{Deferred Evaluation in Modules} + +@defform[(at-end expr)]{ + +When used at the top level of a module, evaluates @scheme[expr] at the end of +the module. This can be useful for calling functions before their definitions. + +@defexamples[ +#:eval (evaluator 'unstable/cce/define) +(module Failure scheme + (f 5) + (define (f x) x)) +(require 'Failure) +(module Success scheme + (require unstable/cce/define) + (at-end (f 5)) + (define (f x) x)) +(require 'Success) +] + +} + +@section{Conditional Binding} + +@deftogether[( +@defform*[[(define-if-unbound x e) + (define-if-unbound (f . args) body ...)]] +@defform[(define-values-if-unbound [x ...] e)] +@defform*[[(define-syntax-if-unbound x e) + (define-syntax-if-unbound (f . args) body ...)]] +@defform[(define-syntaxes-if-unbound [x ...] e)] +)]{ + +These forms define each @scheme[x] (or @scheme[f]) if no such binding exists, or +do nothing if the name(s) is(are) already bound. The +@scheme[define-values-if-unbound] and @scheme[define-syntaxes-if-unbound] forms +raise a syntax error if some of the given names are bound and some are not. + +These are useful for writing programs that are portable across versions of PLT +Scheme with different bindings, to provide an implementation of a binding for +versions that do not have it but use the built-in one in versions that do. + +@defexamples[ +#:eval (evaluator 'unstable/cce/define) +(define-if-unbound x 1) +x +(define y 2) +(define-if-unbound y 3) +y +] + +} + +@section{Renaming Definitions} + +@defform[(define-renamings [new old] ...)]{ + +This form establishes a rename transformer for each @scheme[new] identifier, +redirecting it to the corresponding @scheme[old] identifier. + +@defexamples[ +#:eval (evaluator 'unstable/cce/define) +(define-renamings [def define] [lam lambda]) +(def plus (lam (x y) (+ x y))) +(plus 1 2) +] + +} + +@section{Forward Declarations} + +@defform[(declare-names x ...)]{ + +This form provides forward declarations of identifiers to be defined later. It +is useful for macros which expand to mutually recursive definitions, including +forward references, that may be used at the PLT Scheme top level. + +} + +@section{Definition Shorthands} + +@defform[(define-with-parameter name parameter)]{ + +Defines the form @scheme[name] as a shorthand for setting the parameter +@scheme[parameter]. Specifically, @scheme[(name value body ...)] is equivalent +to @scheme[(parameterize ([parameter value]) body ...)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/define) +(define-with-parameter with-input current-input-port) +(with-input (open-input-string "Tom Dick Harry") (read)) +] + +} + +@defform[(define-single-definition define-one-name define-many-name)]{ + +This form defines a marco @scheme[define-one-name] as a single identifier +definition form with function shorthand like @scheme[define] and +@scheme[define-syntax], based on an existing macro @scheme[define-many-name] +which works like @scheme[define-values] or @scheme[define-syntaxes]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/define) +(define-single-definition define-like define-values) +(define-like x 0) +x +(define-like (f a b c) (printf "~s, ~s\n" a b) c) +(f 1 2 3) +] + +} + +@section{Effectful Transformation} + +@defform[(in-phase1 e)]{ + +This form executes @scheme[e] during phase 1 (the syntax transformation phase) +relative to its context, during pass 1 if it occurs in a head expansion +position. + +} + +@defform[(in-phase1/pass2 e)]{ + +This form executes @scheme[e] during phase 1 (the syntax transformation phase) +relative to its context, during pass 2 (after head expansion). + +} diff --git a/collects/unstable/cce/reference/dict.scrbl b/collects/unstable/cce/reference/dict.scrbl new file mode 100644 index 0000000000..e29378d20b --- /dev/null +++ b/collects/unstable/cce/reference/dict.scrbl @@ -0,0 +1,300 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/dict)) + +@title[#:style 'quiet #:tag "cce-dict"]{Dictionaries} + +@defmodule[unstable/cce/dict] + +This module provides tools for manipulating dictionary values. + +@section{Dictionary Constructors} + +@defproc[(empty-dict [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f] + [#:compare compare (or/c 'eq 'eqv 'equal) equal]) + hash?]{ + +Constructs an empty hash table based on the behavior specified by +@scheme[mutable?], @scheme[weak?], and @scheme[compare]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(empty-dict) +(empty-dict #:mutable? #t) +(empty-dict #:weak? #t) +(empty-dict #:compare 'eqv) +] + +} + +@defproc[(make-dict [d dict?] + [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f] + [#:compare compare (or/c 'eq 'eqv 'equal) equal]) + hash?]{ + +Converts a given dictionary @scheme[d] to a hash table based on the behavior +specified by @scheme[mutable?], @scheme[weak?], and @scheme[compare]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(make-dict '([1 . one] [2 . two])) +(make-dict '([1 . one] [2 . two]) #:mutable? #t) +(make-dict '([1 . one] [2 . two]) #:weak? #t) +(make-dict '([1 . one] [2 . two]) #:compare 'eqv) +] + +} + +@defproc[(custom-dict [equiv? (-> any/c any/c any/c)] + [hash-primary (-> any/c exact-integer?) (lambda (x) 0)] + [hash-secondary (-> any/c exact-integer?) (lambda (x) 0)] + [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f]) + dict?]{ + +Constructs a dictionary based on custom comparison and optional hash functions. +Given no hash functions, the dictionary defaults to a degenerate hash function +and is thus essentially equivalent to a list-based dictionary. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(define table (custom-dict = add1 sub1 #:mutable? #t)) +(dict-set! table 1 'one) +(dict-set! table 2 'two) +(for/list ([(key val) (in-dict table)]) + (cons key val)) +] + +} + +@section{Dictionary Lookup} + +@defproc[(dict-ref! [d (and/c dict? dict-mutable?)] + [k any/c] + [v (or/c (-> any/c) any/c)]) + any/c]{ + +Looks up key @scheme[k] in dictionary @scheme[d]. If @scheme[d] has no entry +for @scheme[k], updates @scheme[d] to map @scheme[k] to the result of +@scheme[(v)] (if @scheme[v] is a procedure) or @scheme[v] (otherwise), and +returns the new mapping. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(define d (make-hash)) +(dict-set! d 1 'one) +(dict-set! d 2 'two) +d +(dict-ref! d 2 'dos) +d +(dict-ref! d 3 'tres) +d +(dict-ref! d 4 gensym) +d +] + +} + +@defproc[(dict-ref/check [d dict?] [k (lambda (k) (dict-has-key? d k))]) + any/c]{ + +Looks up key @scheme[k] in dictionary @scheme[d]. Raises a contract error if +@scheme[d] has no entry for @scheme[k]. Equivalent to @scheme[(dict-ref d k)], +except for the specific exception value raised. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-ref/check '([1 . one] [2 . two] [3 . three]) 2) +] + +} + +@defproc[(dict-ref/identity [d dict?] [k any/c]) any/c]{ + +Looks up key @scheme[k] in dictionary @scheme[d]. Returns @scheme[k] if +@scheme[d] has no entry for @scheme[k]. Equivalent to +@scheme[(dict-ref d k (lambda () k))]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-ref/identity '([1 . one] [2 . two] [3 . three]) 2) +(dict-ref/identity '([1 . one] [2 . two] [3 . three]) 4) +] + +} + +@defproc[(dict-ref/default [d dict?] [k any/c] [v any/c]) any/c]{ + +Looks up key @scheme[k] in dictionary @scheme[d]. Returns @scheme[v] if +@scheme[d] has no entry for @scheme[k]. Equivalent to +@scheme[(dict-ref d k (lambda () v))]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-ref/default '([1 . one] [2 . two] [3 . three]) 2 'other) +(dict-ref/default '([1 . one] [2 . two] [3 . three]) 4 'other) +] + +} + +@defproc[(dict-ref/failure [d dict?] [k any/c] [f (-> any/c)]) any/c]{ + +Looks up key @scheme[k] in dictionary @scheme[d]. Returns the result of +applying @scheme[f] (in tail position) if @scheme[d] has no entry for +@scheme[k]. Equivalent to @scheme[(dict-ref d k f)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-ref/failure '([1 . one] [2 . two] [3 . three]) 2 gensym) +(dict-ref/failure '([1 . one] [2 . two] [3 . three]) 4 gensym) +] + +} + +@section{Dictionary Accessors} + +@defproc[(dict-empty? [d dict?]) boolean?]{ + +Reports whether @scheme[d] is empty (has no keys). + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-empty? '()) +(dict-empty? '([1 . one] [2 . two])) +] + +} + +@defproc[(dict-has-key? [d dict?] [k any/c]) boolean?]{ + +Reports whether @scheme[d] has an entry for @scheme[k]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-has-key? '([1 . one] [2 . two] [3 . three]) 2) +(dict-has-key? '([1 . one] [2 . two] [3 . three]) 4) +] + +} + +@defproc[(dict-domain [d dict?]) list?]{ + +Produces the domain of a dictionary as a list of keys. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-domain '([1 . one] [2 . two] [3 . three])) +] + +} + +@defproc[(dict-range [d dict?]) list?]{ + +Produces the range of a dictionary as a list of values. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-range '([1 . one] [2 . two] [3 . three])) +] + +} + +@section{Dictionary Combinations} + +@defproc[(dict-union [d0 (and/c dict? dict-can-functional-set?)] + [d dict?] ... + [#:combine combine + (-> any/c any/c any/c) + (lambda _ (error 'dict-union ...))] + [#:combine/key combine/key + (-> any/c any/c any/c any/c) + (lambda (k a b) (combine a b))]) + (and/c dict? dict-can-functional-set?)]{ + +Computes the union of @scheme[d0] with each dictionary @scheme[d] by functional +update, adding each element of each @scheme[d] to @scheme[d0] in turn. For each +key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value +@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to +@scheme[(combine/key k v0 v)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(dict-union '([1 . one]) '([2 . two]) '([3 . three])) +(dict-union '([1 . (one uno)] [2 . (two dos)]) + '([1 . (ein une)] [2 . (zwei deux)]) + #:combine/key (lambda (k v1 v2) (append v1 v2))) +] + +} + +@defproc[(dict-union! [d0 (and/c dict? dict-mutable?)] + [d dict?] ... + [#:combine combine + (-> any/c any/c any/c) + (lambda _ (error 'dict-union! ...))] + [#:combine/key combine/key + (-> any/c any/c any/c any/c) + (lambda (k a b) (combine a b))]) + void?]{ + +Computes the union of @scheme[d0] with each dictionary @scheme[d] by mutable +update, adding each element of each @scheme[d] to @scheme[d0] in turn. For each +key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value +@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to +@scheme[(combine/key k v0 v)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(define d (make-hash)) +d +(dict-union! d '([1 . (one uno)] [2 . (two dos)])) +d +(dict-union! d + '([1 . (ein une)] [2 . (zwei deux)]) + #:combine/key (lambda (k v1 v2) (append v1 v2))) +d +] + +} + +@section{Dictionary Structure Properties} + +@defproc[(wrapped-dict-property + [#:unwrap unwrap (-> (and/c dict? pred) dict?)] + [#:wrap wrap (-> dict? (and/c dict? pred)) (lambda (x) x)] + [#:predicate pred (-> any/c boolean?) (lambda (x) #t)] + [#:mutable? mutable? boolean? weak?] + [#:weak? mutable? boolean? #f] + [#:functional? functional? boolean? #t]) + vector?]{ + +Produces a value appropriate for @scheme[prop:dict] for a derived dictionary +type recognized by @scheme[pred]. Dictionaries constructed from this property +will extract a nested dictionary using @scheme[unwrap] and will produce a +wrapped dictionary during functional update using @scheme[wrap]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/dict) +(define-struct table [dict] + #:transparent + #:property prop:dict + (wrapped-dict-property + #:unwrap (lambda (d) (table-dict d)) + #:wrap (lambda (d) (make-table d)) + #:predicate (lambda (d) (table? d)))) +(dict? (make-table '([1 . one] [2 . two]))) +(dict-ref (make-table '([1 . one] [2 . two])) 1) +(dict-set (make-table '([1 . one] [2 . two])) 3 'three) +] + +} + +@section{Contracted Dictionaries} + +This library re-provides @scheme[dict/c] from +@schememodname[unstable/cce/contract]. diff --git a/collects/unstable/cce/reference/drscheme.scrbl b/collects/unstable/cce/reference/drscheme.scrbl new file mode 100644 index 0000000000..6f6c075b42 --- /dev/null +++ b/collects/unstable/cce/reference/drscheme.scrbl @@ -0,0 +1,138 @@ +#lang scribble/doc +@(require scribble/manual + "../scribble.ss" + (for-label scheme/gui + drscheme/tool-lib + unstable/cce/drscheme)) + +@title[#:style 'quiet #:tag "cce-drscheme"]{DrScheme Plugins} + +@defmodule[unstable/cce/drscheme] + +@defthing[language-level@ unit?]{ + +This unit imports @scheme[drscheme:tool^] and exports @scheme[language-level^]. + +} + +@defsignature[language-level^ ()]{ + +@defproc[(make-language-level + [name string?] + [path module-path?] + [mixin (-> class? class?)] ... + [#:number number integer? ...] + [#:hierarchy hierarchy (listof (cons/c string? integer?)) ...] + [#:summary summary string? name] + [#:url url (or/c string? #f) #f] + [#:reader reader + (->* [] [any/c input-port?] (or/c syntax? eof-object?)) + read-syntax]) + (object-provides/c drscheme:language:language<%>)]{ + +Constructs a language level as an instance of +@scheme[drscheme:language:language<%>] with the given @scheme[name] based on the +language defined by the module at @scheme[path]. Applies +@scheme[(drscheme:language:get-default-mixin)] and the given @scheme[mixin]s to +@sigelem[language-level^ simple-language-level%] to construct the class, and +uses the optional keyword arguments to fill in the language's description and +reader. + +} + +@defthing[simple-language-level% + (class-provides/c drscheme:language:language<%> + drscheme:language:module-based-language<%> + drscheme:language:simple-module-based-language<%>)]{ + +Equal to +@scheme[ +(drscheme:language:module-based-language->language-mixin + (drscheme:language:simple-module-based-language->module-based-language-mixin + drscheme:language:simple-module-based-language%))]. + +} + +@defproc[(language-level-render-mixin [to-sexp (-> any/c any/c)] + [show-void? boolean?]) + (mixin-provides/c [drscheme:language:language<%>] [])]{ + +Produces a mixin that overrides @method[drscheme:language:language<%> +render-value/format] to apply @scheme[to-sexp] to each value before printing it, +and to skip @scheme[void?] values (pre-transformation) if @scheme[show-void?] is +@scheme[#f]. + +} + +@defproc[(language-level-capability-mixin [dict dict?]) + (mixin-provides/c [drscheme:language:language<%>] [])]{ + +Produces a mixin that augments @method[drscheme:language:language<%> +capability-value] to look up each key in @scheme[dict], producing the +corresponding value if the key is found and deferring to @scheme[inner] +otherwise. + +} + +@defthing[language-level-no-executable-mixin + (mixin-provides/c [drscheme:language:language<%>] [])]{ + +Overrides @method[drscheme:language:language<%> create-executable] to print an +error message in a dialog box. + +} + +@defthing[language-level-eval-as-module-mixin + (mixin-provides/c [drscheme:language:language<%> + drscheme:language:module-based-language<%>] + [])]{ + +Overrides @method[drscheme:language:language<%> front-end/complete-program] to +wrap terms from the definition in a module based on the language level's +definition module. This duplicates the behavior of the HtDP teaching languages, +for instance. + +} + +@defthing[language-level-macro-stepper-mixin + (mixin-provides/c [drscheme:language:language<%> + language/macro-stepper<%>] + [])]{ + +This mixin enables the macro stepper for its language level. + +} + +@defthing[language-level-check-expect-mixin + (mixin-provides/c [drscheme:language:language<%>] [])]{ + +This mixin overrides @method[drscheme:language:language<%> on-execute] to set up +the @scheme[check-expect] test engine to a language level similarly to the HtDP +teaching languages. + +} + +@defproc[(language-level-metadata-mixin + [reader-module module-path?] + [meta-lines exact-nonnegative-integer?] + [meta->settings (-> string? any/c any/c)] + [settings->meta (-> symbol? any/c string?)]) + (mixin-provides/c [drscheme:language:language<%>] [])]{ + +This mixin constructs a language level that stores metadata in saved files +allowing DrScheme to automatically switch back to this language level upon +opening them. It overrides @method[drscheme:language:language<%> +get-reader-module], @method[drscheme:language:language<%> get-metadata], +@method[drscheme:language:language<%> metadata->settings], and +@method[drscheme:language:language<%> get-metadata-lines]. + +The resulting language level uses the reader from @scheme[reader-module], and is +recognized in files that start with a reader directive for that module path +within the first @scheme[meta-lines] lines. Metadata about the language's +settings is marshalled between a string and a usable value (based on a default +value) by @scheme[meta->settings], and between a usable value for a current +module (with a symbolic name) by @scheme[settings->meta]. + +} + +} diff --git a/collects/unstable/cce/reference/eval.ss b/collects/unstable/cce/reference/eval.ss new file mode 100644 index 0000000000..437e8452fd --- /dev/null +++ b/collects/unstable/cce/reference/eval.ss @@ -0,0 +1,10 @@ +#lang scheme + +(require scheme/sandbox unstable/syntax "../sandbox.ss") + +(define (evaluator . require-specs) + (let* ([ev (make-scribble-evaluator 'scheme)]) + (ev `(require ,@require-specs)) + ev)) + +(provide evaluator) diff --git a/collects/unstable/cce/reference/exn.scrbl b/collects/unstable/cce/reference/exn.scrbl new file mode 100644 index 0000000000..6515d5df35 --- /dev/null +++ b/collects/unstable/cce/reference/exn.scrbl @@ -0,0 +1,31 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/exn)) + +@title[#:style 'quiet #:tag "cce-exn"]{Exceptions} + +@defmodule[unstable/cce/exn] + +This module provides tools for dealing with exceptions. + +@defform[(try expr ...+)]{ + +Executes the first expression @scheme[expr] in the sequence, producing its +result value(s) if it returns any. If it raises an exception instead, +@scheme[try] continues with the next @scheme[expr]. Exceptions raised by +intermediate expressions are reported to the @tech[#:doc '(lib +"scribblings/reference/reference.scrbl")]{current logger} at the @scheme['debug] +level before continuing. Exceptions raised by the final expression are not +caught by @scheme[try]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/exn) +(try (+ 1 2) (+ 3 4)) +(try (+ 'one 'two) (+ 3 4)) +(try (+ 'one 'two) (+ 'three 'four)) +] + +} diff --git a/collects/unstable/cce/reference/function.scrbl b/collects/unstable/cce/reference/function.scrbl new file mode 100644 index 0000000000..fe43d0c8fc --- /dev/null +++ b/collects/unstable/cce/reference/function.scrbl @@ -0,0 +1,289 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/function)) + +@title[#:style 'quiet #:tag "cce-function"]{Functions} + +@defmodule[unstable/cce/function] + +This module provides tools for higher-order programming and creating functions. + +@section{Simple Functions} + +@defproc[(identity [x any/c]) (one-of/c x)]{ + +Returns @scheme[x]. + +} + +@defform[(thunk body ...)]{ + +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) +(define f (thunk (define x 1) (printf "~a\n" x))) +(f) +(f 'x) +(f #:y 'z) +] + +} + +@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?]{ + +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) +(define f (negate exact-integer?)) +(f 1) +(f 'one) +] + +} + +@defproc[((conjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{ + +Combines calls to each function with @scheme[and]. Equivalent to +@scheme[(and (f x ...) ...)] + +@defexamples[ +#:eval (evaluator 'unstable/cce/function) +(define f (conjoin exact? integer?)) +(f 1) +(f 1.0) +(f 1/2) +(f 0.5) +] + +} + +@defproc[((disjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{ + +Combines calls to each function with @scheme[or]. Equivalent to +@scheme[(or (f x ...) ...)] + +@defexamples[ +#:eval (evaluator 'unstable/cce/function) +(define f (disjoin exact? integer?)) +(f 1) +(f 1.0) +(f 1/2) +(f 0.5) +] + +} + +@section{Currying and (Partial) Application} + +@defproc[(call [f (-> A ... B)] [x A] ...) B]{ + +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) +(map call + (list + - * /) + (list 1 2 3 4) + (list 5 6 7 8)) +(define count 0) +(define (inc) + (set! count (+ count 1))) +(define (reset) + (set! count 0)) +(define (show) + (printf "~a\n" count)) +(for-each call (list inc inc show reset show)) +] + +} + +@deftogether[( +@defproc[(papply [f (A ... B ... -> C)] [x A] ...) (B ... -> C)] +@defproc[(papplyr [f (A ... B ... -> C)] [x B] ...) (A ... -> C)] +)]{ + +The @scheme[papply] and @scheme[papplyr] functions partially apply @scheme[f] to +@scheme[x ...], which may include keyword arguments. They obey the following +equations: + +@schemeblock[ +((papply f x ...) y ...) = (f x ... y ...) +((papplyr f x ...) y ...) = (f y ... x ...) +] + +@defexamples[ +#:eval (evaluator 'unstable/cce/function) +(define reciprocal (papply / 1)) +(reciprocal 3) +(reciprocal 4) +(define halve (papplyr / 2)) +(halve 3) +(halve 4) +] + +} + +@deftogether[( +@defproc[(curryn [n exact-nonnegative-integer?] + [f (A0 ... A1 ... ooo An ... -> B)] + [x A0] ...) + (A1 ... -> ooo -> An ... -> B)] +@defproc[(currynr [n exact-nonnegative-integer?] + [f (A1 ... ooo An ... An+1 ... -> B)] + [x An+1] ...) + (An ... -> ooo -> A1 ... -> B)] +)]{ + +@emph{Note:} The @scheme[ooo] above denotes a loosely associating ellipsis. + +The @scheme[curryn] and @scheme[currynr] functions construct a curried version +of @scheme[f], specialized at @scheme[x ...], that produces a result after +@scheme[n] further applications. Arguments at any stage of application may +include keyword arguments, so long as no keyword is duplicated. These curried +functions obey the following equations: + +@schemeblock[ +(curryn 0 f x ...) = (f x ...) +((curryn (+ n 1) f x ...) y ...) = (curryn n f x ... y ...) + +(currynr 0 f x ...) = (f x ...) +((currynr (+ n 1) f x ...) y ...) = (currynr n f y ... x ...) +] + +The @scheme[call], @scheme[papply], and @scheme[papplyr] utilities are related +to @scheme[curryn] and @scheme[currynr] in the following manner: + +@schemeblock[ +(call f x ...) = (curryn 0 f x ...) = (currynr 0 f x ...) +(papply f x ...) = (curryn 1 f x ...) +(papplyr f x ...) = (currynr 1 f x ...) +] + +@defexamples[ +#:eval (evaluator 'unstable/cce/function) + +(define reciprocal (curryn 1 / 1)) +(reciprocal 3) +(reciprocal 4) + +(define subtract-from (curryn 2 -)) +(define from-10 (subtract-from 10)) +(from-10 5) +(from-10 10) +(define from-0 (subtract-from 0)) +(from-0 5) +(from-0 10) + +(define halve (currynr 1 / 2)) +(halve 3) +(halve 4) + +(define subtract (currynr 2 -)) +(define minus-10 (subtract 10)) +(minus-10 5) +(minus-10 10) +(define minus-0 (subtract 0)) +(minus-0 5) +(minus-0 10) + +] + +} + +@section{Eta Expansion} + +@defform[(eta f)]{ + +Produces a function equivalent to @scheme[f], except that @scheme[f] is +evaluated every time it is called. + +This is useful for function expressions that may be run, but not called, before +@scheme[f] is defined. The @scheme[eta] expression will produce a function +without evaluating @scheme[f]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/function) +(define f (eta g)) +f +(define g (lambda (x) (+ x 1))) +(f 1) +] + +} + +@defform[(eta* f x ...)]{ + +Produces a function equivalent to @scheme[f], with argument list @scheme[x ...]. +In simple cases, this is equivalent to @scheme[(lambda (x ...) (f x ...))]. +Optional (positional or keyword) arguments are not allowed. + +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) +(define f (eta* g x)) +f +(procedure-arity f) +(define g (lambda (x) (+ x 1))) +(f 1) +] + +} + +@section{Parameter Arguments} + +@defform/subs[ + (lambda/parameter (param-arg ...) body ...) + ([param-arg param-arg-spec (code:line keyword param-spec)] + [param-arg-spec id [id default-expr] [id #:param param-expr]]) +]{ + +Constructs a function much like @scheme[lambda], except that some optional +arguments correspond to the value of a parameter. For each clause of the form +@scheme[[id #:param param-expr]], @scheme[param-expr] must evaluate to a value +@scheme[param] satisfying @scheme[parameter?]. The default value of the +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) +(define p (open-output-string)) +(define hello-world + (lambda/parameter ([port #:param current-output-port]) + (display "Hello, World!") + (newline port))) +(hello-world p) +(get-output-string p) +] + +} diff --git a/collects/unstable/cce/reference/gui.scrbl b/collects/unstable/cce/reference/gui.scrbl new file mode 100644 index 0000000000..e15053b97c --- /dev/null +++ b/collects/unstable/cce/reference/gui.scrbl @@ -0,0 +1,80 @@ +#lang scribble/doc +@(require scribble/manual + "../scribble.ss" + (for-label scheme/gui unstable/cce/gui)) + +@title[#:style 'quiet #:tag "cce-gui"]{GUI Widgets} + +@defmodule[unstable/cce/gui] + +@section{Locked Text Fields} + +These classes and mixins provide text and combo field controls that cannot be +directly edited by the user, but may be updated by other controls. + +@defmixin[locked-text-field-mixin (text-field%) ()]{ + +This mixin updates text field classes to prevent user edits, but allow +programmatic update of the text value. It also sets the undo history length to +a default of 0, as user undo commands are disabled and the history takes up +space. + +@defconstructor[([undo-history exact-nonnegative-integer? 0])]{ + +The mixin adds the @scheme[undo-history] initialization argument to control the +length of the undo history. It defaults to 0 to save space, but may be set +higher. + +The mixin inherits all the initialization arguments of its parent class; it does +not override any of them. + +} + +@defmethod[#:mode override (set-value [str string?]) void?]{ + +Unlocks the text field's nested editor, calls the parent class's +@method[text-field% set-value], and then re-locks the editor. + +} + +} + +@defclass[locked-text-field% text-field% ()]{ + +Equal to @scheme[(locked-text-field-mixin text-field%)]. + +} + +@defclass[locked-combo-field% combo-field% ()]{ + +Equal to @scheme[(locked-text-field-mixin combo-field%)]. + +} + +@section{Union GUIs} + +@defmixin[union-container-mixin (area-container<%>) ()]{ + +This mixin modifies a container class to display only one of its child areas at +a time, but to leave room to switch to any of them. + +@defmethod[(choose [child (is-a?/c subwindow<%>)]) void?]{ + +This method changes which of the container's children is displayed. The chosen +child is shown and the previous choice is hidden. + +} + +} + +@defclass[union-pane% pane% ()]{ + +Equal to @scheme[(union-container-mixin pane%)]. + +} + +@defclass[union-panel% panel% ()]{ + +Equal to @scheme[(union-container-mixin panel%)]. + +} diff --git a/collects/unstable/cce/reference/hash.scrbl b/collects/unstable/cce/reference/hash.scrbl new file mode 100644 index 0000000000..cc150c314b --- /dev/null +++ b/collects/unstable/cce/reference/hash.scrbl @@ -0,0 +1,223 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/hash)) + +@title[#:style 'quiet #:tag "cce-hash"]{Hash Tables} + +@defmodule[unstable/cce/hash] + +This module provides tools for manipulating hash tables. + +@section{Hash Table Construction} + +@defform/subs[ +(hash immutable-hash-type [key-expr value-expr] ...) +[(immutable-hash-type code:blank #:eq #:eqv #:equal)] +]{ + +Produces an immutable hash table based on the given comparison, defaulting to +@scheme[#:equal], and mapping the result of each @scheme[key-expr] to the result +of each @scheme[value-expr]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash ['one 1] ['two 2]) +(hash #:eq ['one 1] ['two 2]) +(hash #:eqv ['one 1] ['two 2]) +(hash #:equal ['one 1] ['two 2]) +] + +} + +@defform/subs[ +(hash! mutable-hash-spec [key-expr value-expr] ...) +[(mutable-hash-spec (code:line mutable-hash-type mutable-hash-weak) + (code:line mutable-hash-weak mutable-hash-type)) + (mutable-hash-type code:blank #:eq #:eqv #:equal) + (mutable-hash-weak code:blank #:weak)] +]{ + +Produces a mutable hash table based on the given comparison and weakness +specification, defaulting to @scheme[#:equal] and not @scheme[#:weak], and +mapping the result of each @scheme[key-expr] to the result of each +@scheme[value-expr]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash! ['one 1] ['two 2]) +(hash! #:eq ['one 1] ['two 2]) +(hash! #:eqv #:weak ['one 1] ['two 2]) +(hash! #:weak #:equal ['one 1] ['two 2]) +] + +} + +@section{Hash Table Lookup} + +@defproc[(hash-ref/check [h hash?] [k (lambda (k) (hash-has-key? h k))]) + any/c]{ + +Looks up key @scheme[k] in hash table @scheme[h]. Raises a contract error if +@scheme[h] has no entry for @scheme[k]. Equivalent to @scheme[(hash-ref h k)], +except for the specific exception value raised. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-ref/check (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2) +] + +} + +@defproc[(hash-ref/identity [h hash?] [k any/c]) any/c]{ + +Looks up key @scheme[k] in hash table @scheme[h]. Returns @scheme[k] if +@scheme[h] has no entry for @scheme[k]. Equivalent to +@scheme[(hash-ref h k (lambda () k))]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-ref/identity (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2) +(hash-ref/identity (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4) +] + +} + +@defproc[(hash-ref/default [h hash?] [k any/c] [v any/c]) any/c]{ + +Looks up key @scheme[k] in hash table @scheme[h]. Returns @scheme[v] if +@scheme[h] has no entry for @scheme[k]. Equivalent to +@scheme[(hash-ref h k (lambda () v))]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-ref/default (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2 'other) +(hash-ref/default (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4 'other) +] + +} + +@defproc[(hash-ref/failure [h hash?] [k any/c] [f (-> any/c)]) any/c]{ + +Looks up key @scheme[k] in hash table @scheme[h]. Returns the result of +applying @scheme[f] (in tail position) if @scheme[h] has no entry for +@scheme[k]. Equivalent to @scheme[(hash-ref h k f)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-ref/failure (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2 gensym) +(hash-ref/failure (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4 gensym) +] + +} + +@section{Hash Table Accessors} + +@defproc[(hash-equal? [h hash?]) boolean?]{ + +Reports whether @scheme[h] maps keys according to @scheme[equal?]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-equal? #hash()) +(hash-equal? #hasheq()) +(hash-equal? #hasheqv()) +] + +} + +@defproc[(hash-has-key? [h hash?] [k any/c]) boolean?]{ + +Reports whether @scheme[h] has an entry for @scheme[k]. This function is +re-exported from @schememodname[scheme/base]. In versions of PLT Scheme before +@scheme[hash-has-key?] was implemented, this module provides its own definition. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-has-key? (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 2) +(hash-has-key? (make-immutable-hash '([1 . one] [2 . two] [3 . three])) 4) +] + +} + +@defproc[(hash-domain [h hash?]) list?]{ + +Produces the domain of a hash table as a list of keys. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-domain (make-immutable-hash '([1 . one] [2 . two] [3 . three]))) +] + +} + +@defproc[(hash-range [h hash?]) list?]{ + +Produces the range of a hash table as a list of values. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-range (make-immutable-hash '([1 . one] [2 . two] [3 . three]))) +] + +} + +@section{Hash Table Combinations} + +@defproc[(hash-union [h0 (and/c hash? hash-can-functional-set?)] + [h hash?] ... + [#:combine combine + (-> any/c any/c any/c) + (lambda _ (error 'hash-union ...))] + [#:combine/key combine/key + (-> any/c any/c any/c any/c) + (lambda (k a b) (combine a b))]) + (and/c hash? hash-can-functional-set?)]{ + +Computes the union of @scheme[h0] with each hash table @scheme[h] by functional +update, adding each element of each @scheme[h] to @scheme[h0] in turn. For each +key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value +@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to +@scheme[(combine/key k v0 v)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(hash-union (make-immutable-hash '([1 . one])) (make-immutable-hash '([2 . two])) (make-immutable-hash '([3 . three]))) +(hash-union (make-immutable-hash '([1 . (one uno)] [2 . (two dos)])) + (make-immutable-hash '([1 . (ein une)] [2 . (zwei deux)])) + #:combine/key (lambda (k v1 v2) (append v1 v2))) +] + +} + +@defproc[(hash-union! [h0 (and/c hash? hash-mutable?)] + [h hash?] ... + [#:combine combine + (-> any/c any/c any/c) + (lambda _ (error 'hash-union ...))] + [#:combine/key combine/key + (-> any/c any/c any/c any/c) + (lambda (k a b) (combine a b))]) + void?]{ + +Computes the union of @scheme[h0] with each hash table @scheme[h] by mutable +update, adding each element of each @scheme[h] to @scheme[h0] in turn. For each +key @scheme[k] and value @scheme[v], if a mapping from @scheme[k] to some value +@scheme[v0] already exists, it is replaced with a mapping from @scheme[k] to +@scheme[(combine/key k v0 v)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/hash) +(define h (make-hash)) +h +(hash-union! h (make-immutable-hash '([1 . (one uno)] [2 . (two dos)]))) +h +(hash-union! h + (make-immutable-hash '([1 . (ein une)] [2 . (zwei deux)])) + #:combine/key (lambda (k v1 v2) (append v1 v2))) +h +] + +} diff --git a/collects/unstable/cce/reference/manual.scrbl b/collects/unstable/cce/reference/manual.scrbl new file mode 100644 index 0000000000..a9ba60de16 --- /dev/null +++ b/collects/unstable/cce/reference/manual.scrbl @@ -0,0 +1,49 @@ +#lang scribble/doc +@(require scribble/manual + "../../scribblings/utils.rkt" + "../scribble.ss" + (for-label scheme/base)) + +@title[#:style '(toc)]{@bold{Carl Eastlund's Scheme Utilities}} + +@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]] + +@table-of-contents[] + +@include-section["function.scrbl"] + +@include-section["values.scrbl"] + +@include-section["text.scrbl"] +@include-section["regexp.scrbl"] +@include-section["web.scrbl"] + +@include-section["set.scrbl"] +@include-section["dict.scrbl"] +@include-section["hash.scrbl"] +@include-section["queue.scrbl"] + +@include-section["syntax.scrbl"] +@include-section["define.scrbl"] + +@include-section["match.scrbl"] + +@include-section["class.scrbl"] + +@include-section["contract.scrbl"] + +@include-section["require-provide.scrbl"] +@include-section["planet.scrbl"] + +@include-section["exn.scrbl"] + +@include-section["port.scrbl"] + +@include-section["debug.scrbl"] + +@include-section["sandbox.scrbl"] +@include-section["scribble.scrbl"] + +@include-section["gui.scrbl"] +@include-section["drscheme.scrbl"] +@include-section["slideshow.scrbl"] diff --git a/collects/unstable/cce/reference/match.scrbl b/collects/unstable/cce/reference/match.scrbl new file mode 100644 index 0000000000..7b15321b49 --- /dev/null +++ b/collects/unstable/cce/reference/match.scrbl @@ -0,0 +1,81 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/match)) + +@title[#:style 'quiet #:tag "cce-match"]{Pattern Matching} + +@defmodule[unstable/cce/match] + +This module provides tools for pattern matching with @scheme[match]. + +@defform[(match? val-expr pat ...)]{ + +Returns @scheme[#t] if the result of @scheme[val-expr] matches any of +@scheme[pat], and returns @scheme[#f] otherwise. + +@defexamples[ +#:eval (evaluator 'unstable/cce/match) +(match? (list 1 2 3) + (list a b c) + (vector x y z)) +(match? (vector 1 2 3) + (list a b c) + (vector x y z)) +(match? (+ 1 2 3) + (list a b c) + (vector x y z)) +] + +} + +@defform[(define-struct-pattern pat-id struct-id)]{ + +Defines @scheme[pat-id] as a match expander that takes one pattern argument per +field of the structure described by @scheme[struct-id]. The resulting match +expander recognizes instances of the structure and matches their fields against +the corresponding patterns. + +@defexamples[ +#:eval (evaluator 'unstable/cce/match) +(define-struct pair [a b] #:transparent) +(define-struct-pattern both pair) +(match (make-pair 'left 'right) + [(both a b) (list a b)]) +] + +} + +@defform[(as ([lhs-id rhs-expr] ...) pat ...)]{ + +As a match expander, binds each @scheme[lhs-id] as a pattern variable with the +result value of @scheme[rhs-expr], and continues matching each subsequent +@scheme[pat]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/match) +(match (list 1 2 3) + [(as ([a 0]) (list b c d)) (list a b c d)]) +] + +} + +@defform*[[($ struct-id expr ...) ($ struct-id pat ...)]]{ + +As an expression, constructs an instance of the structure described by +@scheme[struct-id] with fields specified by each @scheme[expr]. + +As a match expander, matches instances of the structure described by +@scheme[struct-id] with fields matched by each @scheme[pat]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/match) +(define-struct pair [a b] #:transparent) +($ pair 1 2) +(match ($ pair 1 2) + [($ pair a b) (list a b)]) +] + +} diff --git a/collects/unstable/cce/reference/planet.scrbl b/collects/unstable/cce/reference/planet.scrbl new file mode 100644 index 0000000000..598a6b33cb --- /dev/null +++ b/collects/unstable/cce/reference/planet.scrbl @@ -0,0 +1,35 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + scribble/bnf + "../scribble.ss" + "eval.ss") +@(require (for-label scheme/base scribble/manual unstable/cce/planet)) + +@title[#:style 'quiet #:tag "cce-planet"]{@|PLaneT| Packages} + +@defmodule[unstable/cce/planet] + +This module provides tools relating to @|PLaneT| packages. In addition to the +binding described below, it provides @scheme[define-planet-package] and +@scheme[this-package-in] from @schememodname[unstable/cce/require-provide], and +@scheme[make-planet-path], @scheme[syntax-source-planet-package], +@scheme[syntax-source-planet-package-owner], +@scheme[syntax-source-planet-package-name], +@scheme[syntax-source-planet-package-major], +@scheme[syntax-source-planet-package-minor], and +@scheme[syntax-source-planet-package-symbol] from +@schememodname[unstable/cce/syntax]. + +@defform*[[ +(this-package-version-symbol) +(this-package-version-symbol path) +]]{ + +Produces a symbol corresponding to a @scheme[planet] module path for the current +planet package, possibly with a @nonterm{path} (from the grammar of +@scheme[planet] module specs) into the package. This is similar to +@scheme[this-package-version] and similar tools from +@schememodname[planet/util]. + +} diff --git a/collects/unstable/cce/reference/port.scrbl b/collects/unstable/cce/reference/port.scrbl new file mode 100644 index 0000000000..352955ded7 --- /dev/null +++ b/collects/unstable/cce/reference/port.scrbl @@ -0,0 +1,105 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/port)) + +@title[#:style 'quiet #:tag "cce-port"]{Ports} + +@defmodule[unstable/cce/port] + +This module provides tools for port I/O. + +@defproc[(eprintf [fmt string?] [arg any/c] ...) void?]{ + +Like @scheme[printf], but prints to @scheme[(current-error-port)]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/port) +(eprintf "Danger, ~a!" "Will Robinson") +] + +} + +@defproc[(read-all [reader (-> any/c) read] + [port input-port? (current-input-port)]) + list?]{ + +This function produces a list of all the values produced by calling +@scheme[(reader)] while @scheme[current-input-port] is set to @scheme[port], up +until it produces @scheme[eof]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/port) +(read-all read (open-input-string "1 2 3")) +(parameterize ([current-input-port (open-input-string "a b c")]) + (read-all)) +] + +} + +@defproc[(read-all-syntax [reader (-> (or/c syntax? eof-object?)) read] + [port input-port? (current-input-port)]) + (syntax/c list?)]{ + +This function produces a syntax object containing a list of all the syntax +objects produced by calling @scheme[(reader)] while @scheme[current-input-port] +is set to @scheme[port], up until it produces @scheme[eof]. The source location +of the result spans the entire portion of the port that was read. + +@defexamples[ +#:eval (evaluator 'unstable/cce/port) +(define port1 (open-input-string "1 2 3")) +(port-count-lines! port1) +(read-all-syntax read-syntax port1) +(define port2 (open-input-string "a b c")) +(port-count-lines! port2) +(parameterize ([current-input-port port2]) + (read-all-syntax)) +] + +} + +@defproc[(port->srcloc [port port?] + [source any/c (object-name port)] + [span exact-nonnegative-integer? 0]) + srcloc?]{ + +Produces a @scheme[srcloc] structure representing the current position of a +port, using the provided @scheme[source] and @scheme[span] values to fill in +missing fields. This function relies on @scheme[port-next-location], so line +counting must be enabled for @scheme[port] to get meaningful results. + +@defexamples[ +#:eval (evaluator 'unstable/cce/port) +(define port (open-input-string "1 2 3")) +(port-count-lines! port) +(read port) +(port->srcloc port) +(port->srcloc port "1 2 3" 1) +] + +} + +@defproc[(read-available-bytes [port input-port? (current-input-port)]) + (or/c bytes? eof-object?)]{ + +This function reads all immediately available bytes from a port and produces a +byte string containing them. If there are no bytes available and the port is +known to have no more input, it produces @scheme[eof]; if there are none +available but the port may have more input, it produces an empty byte string. +This procedure never blocks to wait for input from the port. + +@defexamples[ +#:eval (evaluator 'unstable/cce/port) +(define-values [in out] (make-pipe)) +(parameterize ([current-input-port in]) (read-available-bytes)) +(write-byte (char->integer #\c) out) +(read-available-bytes in) +(read-available-bytes in) +(close-output-port out) +(read-available-bytes in) +] + +} diff --git a/collects/unstable/cce/reference/queue.scrbl b/collects/unstable/cce/reference/queue.scrbl new file mode 100644 index 0000000000..7d237f16eb --- /dev/null +++ b/collects/unstable/cce/reference/queue.scrbl @@ -0,0 +1,67 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/queue)) + +@title[#:style 'quiet #:tag "cce-queue"]{Imperative Queues} + +@defmodule[unstable/cce/queue] + +This module provides a mutable queue representation. + +@defproc[(make-queue) queue/c]{ +Produces an empty queue. +} + +@defproc[(enqueue! [q queue/c] [v any/c]) void?]{ +Adds an element to the back of a queue. +} + +@defproc[(dequeue! [q nonempty-queue/c]) any/c]{ +Removes an element from the front of a nonempty queue, and returns that element. + +@defexamples[ +#:eval (evaluator 'unstable/cce/queue) +(define q (make-queue)) +(enqueue! q 1) +(dequeue! q) +(enqueue! q 2) +(enqueue! q 3) +(dequeue! q) +(dequeue! q) +] +} + +@defproc[(queue-empty? [q queue/c]) boolean?]{ +Recognizes whether a queue is empty or not. + +@defexamples[ +#:eval (evaluator 'unstable/cce/queue) +(define q (make-queue)) +(queue-empty? q) +(enqueue! q 1) +(queue-empty? q) +(dequeue! q) +(queue-empty? q) +] +} + +@defproc[(queue? [v any/c]) boolean?]{ +This predicate recognizes queues. + +@defexamples[ +#:eval (evaluator 'unstable/cce/queue) +(queue? (make-queue)) +(queue? 'not-a-queue) +] +} + +@deftogether[( +@defthing[queue/c flat-contract?] +@defthing[nonempty-queue/c flat-contract?] +)]{ +These contracts recognize queues; the latter requires the queue to contain at +least one value. +} diff --git a/collects/unstable/cce/reference/regexp.scrbl b/collects/unstable/cce/reference/regexp.scrbl new file mode 100644 index 0000000000..df5750b5a1 --- /dev/null +++ b/collects/unstable/cce/reference/regexp.scrbl @@ -0,0 +1,129 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/regexp)) + +@title[#:style 'quiet #:tag "cce-regexp"]{Regular Expressions} + +@defmodule[unstable/cce/regexp] + +This module provides tools for building strings which can be compiled to regular +expressions. In particular, the constructors wrap their arguments in +appropriate delimeters to prevent misparsing after concatenation. + +@defproc[(regexp-sequence [#:start start string? ""] + [#:between between string? ""] + [#:end end string? ""] + [re string?] ...) + string?]{ + +Produces a regular expression string that matches @scheme[start], followed by +each @scheme[re] interleaved with @scheme[between], followed by @scheme[end]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re + (pregexp + (regexp-sequence "[0-9]+" "[0-9]+" "[0-9]+" + #:start (regexp-quote "(") + #:between (regexp-quote ",") + #:end (regexp-quote ")")))) +(regexp-match-exact? re "(1,10,100)") +(regexp-match-exact? re "(1,10)") +(regexp-match-exact? re " ( 1 , 10 , 100 ) ") +] + +} + +@defproc[(regexp-or [re string?] ...+) string?]{ + +Produces a regular expression string that matches any of the given @scheme[re]s. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re (pregexp (regexp-or "[0-9]+" "[a-z]"))) +(regexp-match-exact? re "123") +(regexp-match-exact? re "c") +(regexp-match-exact? re "12c") +] + +} + +@defproc[(regexp-maybe [re string?] ...+) string?]{ + +Produces a regular expression string that matches either the empty string, or +the concatenation of all the given @scheme[re]s. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re (pregexp (regexp-maybe "[0-9]+" "[.]" "[0-9]+"))) +(regexp-match-exact? re "123.456") +(regexp-match-exact? re "") +(regexp-match-exact? re "123") +] + +} + +@defproc[(regexp-star [re string?] ...+) string?]{ + +Produces a regular expression string that matches zero or more consecutive +occurrences of the concatenation of the given @scheme[re]s. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re (pregexp (regexp-star "a" "b" "c"))) +(regexp-match-exact? re "") +(regexp-match-exact? re "abc") +(regexp-match-exact? re "abcabcabc") +(regexp-match-exact? re "a") +] + +} + +@defproc[(regexp-plus [re string?] ...+) string?]{ + +Produces a regular expression string that matches one or more consecutive +occurrences of the concatenation of the given @scheme[re]s. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re (pregexp (regexp-plus "a" "b" "c"))) +(regexp-match-exact? re "") +(regexp-match-exact? re "abc") +(regexp-match-exact? re "abcabcabc") +(regexp-match-exact? re "a") +] + +} + +@defproc[(regexp-save [re string?] ...+) string?]{ + +Produces a regular expression string that matches the concatenation of the given +@scheme[re]s and saves the result. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re + (pregexp (regexp-sequence (regexp-save "[0-9]+") "\\1"))) +(regexp-match-exact? re "11") +(regexp-match-exact? re "123123") +(regexp-match-exact? re "123456") +] + +} + +@defproc[(regexp-multi [re string?] ...+) string?]{ + +Produces a regular expression string that matches the concatenation of the given +@scheme[re]s in multiple-line mode. + +@defexamples[ +#:eval (evaluator 'unstable/cce/regexp) +(define re (pregexp (regexp-multi "^abc$"))) +(regexp-match? re "abc") +(regexp-match? re "xyz\nabc\ndef") +] + +} diff --git a/collects/unstable/cce/reference/require-provide.scrbl b/collects/unstable/cce/reference/require-provide.scrbl new file mode 100644 index 0000000000..1d9475fe53 --- /dev/null +++ b/collects/unstable/cce/reference/require-provide.scrbl @@ -0,0 +1,107 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/require-provide)) + +@title[#:style 'quiet #:tag "cce-require-provide"]{Require and Provide} + +@defmodule[unstable/cce/require-provide] + +This module provides tools for managing the imports and exports of modules. + +@defform[(require/provide module-path ...)]{ + +Re-exports all bindings provided by each @scheme[module-path]. Equivalent to: + +@schemeblock[ +(require module-path ...) +(provide (all-from-out module-path ...)) +] + +} + +@defform[(quote-require require-spec ...)]{ + +Produces the names exported by the @scheme[require-spec]s as a list of symbols. + +@examples[ +#:eval (evaluator 'unstable/cce/require-provide) +(quote-require scheme/bool scheme/function) +] + +} + +@defform[(local-require require-spec ...)]{ + +This form performs a require into a local definition context. It achieves this +by lifting a @scheme[#%require] form to the top level and introducing the +bindings locally with rename transformers. For many purposes this is the same +as a regular @scheme[require]; however, only bindings for the current phase are +made available, and all names are introduced as syntax bindings even if the +exported identifiers included value bindings. + +} + +@defform[(do-local-require rename require-spec ...)]{ + +This form generalizes @scheme[do-local-require] to use an arbitrary macro +@scheme[rename] (of the same syntactic form as @scheme[define-renamings]) to +introduce local bindings. + +} + +@defform[(define-planet-package name package)]{ + +Defines a shortcut @scheme[name] for importing modules from planet package +@scheme[package]. Subsequently, @scheme[(name module)] is equivalent to +@scheme[(planet package/module)] as a require path. For instance, to import the +@scheme[text] and @scheme[web] modules from this package: + +@schemeblock[ +(define-planet-package my-package cce/scheme) +(require (my-package web) (my-package text)) +] + +The above @scheme[require] is equivalent to: + +@schemeblock[ +(require (planet cce/scheme/web) (planet cce/scheme/text)) +] + +} + +@defform[(define-collection name collect)]{ + +Defines a shortcut @scheme[name] for importing modules from @scheme[collect] and +its subcollections. Subsequently, @scheme[(name)] is equivalent to +@scheme[collect] as a require path, and @scheme[(name path)] is equivalent to +@scheme[collect/path]. + +@schemeblock[ +(define-collection macro syntax) +(require (macro parse)) +] + +The above @scheme[require] is equivalent to the below: + +@schemeblock[ +(require syntax/parse) +] + +} + +@defform[ +(this-package-in path) +]{ + +This +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{require transformer} +imports the file at @scheme[path] in the current planet package. For instance, +in the package @schememodname[(planet cce/scheme:7)], writing: +@schemeblock[(require (this-package-in function))] +... is equivalent to writing: +@schemeblock[(require (planet cce/scheme:7/function))] + +} diff --git a/collects/unstable/cce/reference/sandbox.scrbl b/collects/unstable/cce/reference/sandbox.scrbl new file mode 100644 index 0000000000..d1da7639a6 --- /dev/null +++ b/collects/unstable/cce/reference/sandbox.scrbl @@ -0,0 +1,66 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme scheme/sandbox unstable/cce/sandbox)) + +@title[#:style 'quiet #:tag "cce-sandbox"]{Sandboxed Evaluation} + +@defmodule[unstable/cce/sandbox] + +This module provides tools for sandboxed evaluation. + +@deftogether[( +@defproc[(make-trusted-evaluator + [language (or/c module-path? + (list/c 'special symbol?) + (cons/c 'begin list?))] + [input-program any/c] ... + [#:requires requires (listof (or/c module-path? path?))] + [#:allow-read allow (listof or/c module-path? path?)]) + (any/c . -> . any)] +@defproc[(make-trusted-module-evaluator + [module-decl (or/c syntax? pair?)] + [#:language lang (or/c #f module-path?)] + [#:allow-read allow (listof (or/c module-path? path?))]) + (any/c . -> . any)] +)]{ +These procedures wrap calls to @scheme[make-evaluator] and +@scheme[make-module-evaluator], respectively, with +@scheme[call-with-trusted-sandbox-configuration] (introduced in PLT 4.1.3.6). +In older versions of PLT Scheme, they simulate the trusted configuration as +closely as possible. +} + +@deftogether[( +@defproc[(make-scribble-evaluator + [language (or/c module-path? + (list/c 'special symbol?) + (cons/c 'begin list?))] + [input-program any/c] ... + [#:requires requires (listof (or/c module-path? path?))] + [#:allow-read allow (listof or/c module-path? path?)]) + (any/c . -> . any)] +@defproc[(make-scribble-module-evaluator + [module-decl (or/c syntax? pair?)] + [#:language lang (or/c #f module-path?)] + [#:allow-read allow (listof (or/c module-path? path?))]) + (any/c . -> . any)] +)]{ +These procedures wrap calls to @scheme[make-trusted-evaluator] and +@scheme[make-trusted-module-evaluator], respectively, with parameterizations +setting @scheme[sandbox-output] and @scheme[sandbox-error-output] to +@scheme['string]. +} + +@defproc[(make-sandbox-namespace-specs [make-ns (-> namespace?)] + [path module-path?] ...) + (cons/c (-> namespace?) (listof module-path?))]{ + +This function produces a value for the parameter +@scheme[sandbox-namespace-specs] such that new sandbox evaluators start with a +namespace constructed by @scheme[make-ns] and share a set of instances of the +modules referred to by the given @scheme[path]s. + +} \ No newline at end of file diff --git a/collects/unstable/cce/reference/scribble.scrbl b/collects/unstable/cce/reference/scribble.scrbl new file mode 100644 index 0000000000..ed17c6d717 --- /dev/null +++ b/collects/unstable/cce/reference/scribble.scrbl @@ -0,0 +1,77 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + scribble/bnf + "../scribble.ss" + (for-label scheme/base scribble/manual unstable/cce/scribble)) + +@title[#:tag "cce-scribble"]{Scribble Documentation} + +@defmodule[unstable/cce/scribble] + +This module provides tools for Scribble documentation; specifically, of +@|PLaneT| packages. In addition to the bindings described below, this module +provides @scheme[this-package-version-symbol] from +@schememodname[unstable/cce/planet], @scheme[this-package-in] from +@schememodname[unstable/cce/require-provide], and +@scheme[make-scribble-evaluator] and @scheme[make-scribble-module-evaluator] +from @schememodname[unstable/cce/sandbox]. + +@defform*[[ +(defmodule/this-package) +(defmodule/this-package #:use-sources [src-path ...] [src ...]) +(defmodule/this-package path) +(defmodule/this-package path #:use-sources [src-path ...] [src ...]) +]]{ + +This Scribble form corresponds to @scheme[defmodule] within a planet package. +The displayed module path is a @scheme[planet] module path to the current planet +package, possibly with a @nonterm{path} (from the grammar of @scheme[planet] +module specs) into the package. If the @scheme[#:use-sources] option is +present, each @scheme[src-path] is similarly treated as a path into the current +planet package, while each @scheme[src] is treated normally. Both sets of paths +are concatenated and passed to the normal @scheme[defmodule]. + +} + +@defform*[[ +(defmodule*/no-declare/this-package [src-path ...] [src ...]) +]]{ + +This Scribble form corresponds to @scheme[defmodule*/no-declare] within a planet +package. The displayed module paths are @scheme[planet] module paths to the +current planet package, possibly with @nonterm{path}s (from the grammar of +@scheme[planet] module specs) into the package. Each @scheme[src-path] is +similarly treated as a path into the current planet package, while each +@scheme[src] is treated normally. Both sets of paths are concatenated and +passed to the normal @scheme[defmodule*/no-declare]. + +} + +@defform*[[ +(schememodname/this-package) +(schememodname/this-package path) +]]{ + +This Scribble form corresponds to @scheme[schememodname] much like +@scheme[defmodule/this-package] above corresponds to @scheme[defmodule]. The +@scheme[path], if present, is treated as a @nonterm{path} (from the grammar of +@scheme[planet] module specs) into the current planet package, and converted +into a @scheme[planet] module spec. + +} + +@defform*[[ +(declare-exporting/this-package [mod-path ...] [mod ...]) +(declare-exporting/this-package [mod-path ...] [mod ...] + #:use-sources [src-path ...] [src ...]) +]]{ + +This Scribble form corresponds to @scheme[declare-exporting] much like +@scheme[defmodule/this-package] above corresponds to @scheme[defmodule]. Each +@scheme[mod-path] and @scheme[src-path] is treated as a @nonterm{path} (from the +grammar of @scheme[planet] module specs) into the current package. They are +concatenated with the lists of @scheme[mod]s and @scheme[src]s, respectively, +and passed to the normal @scheme[declare-exporting]. + +} diff --git a/collects/unstable/cce/reference/set.scrbl b/collects/unstable/cce/reference/set.scrbl new file mode 100644 index 0000000000..bfac701144 --- /dev/null +++ b/collects/unstable/cce/reference/set.scrbl @@ -0,0 +1,414 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/set)) + +@title[#:style 'quiet #:tag "cce-set"]{Sets} + +@defmodule[unstable/cce/set] + +This module provides tools for representing finite sets. + +@section{Set Constructors} + +@defproc[(set [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f] + [#:compare compare (or/c 'eq 'eqv 'equal) 'equal] + [x any/c] ...) + set?]{ + +Produces a hash table-based set using the hash table properties described by +any keyword arguments, and the given values as elements of the set. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set 1 2 3) +(set #:mutable? #t 1 2 3) +(set #:weak? #t 1 2 3) +(set #:compare 'eqv 1 2 3) +] + +} + +@defproc[(empty-set [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f] + [#:compare compare (or/c 'eq 'eqv 'equal) 'equal]) + set?]{ + +Produces an empty hash table-based set using the hash table properties described +by any keyword arguments. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(empty-set) +(empty-set #:mutable? #t) +(empty-set #:weak? #t) +(empty-set #:compare 'eqv) +] + +} + +@defproc[(list->set [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f] + [#:compare compare (or/c 'eq 'eqv 'equal) 'equal] + [lst list?]) + set?]{ + +Produces a hash table-based set using the hash table properties described by +any keyword arguments, with the elements of the given list as the elements of +the set. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(list->set '(1 2 3)) +(list->set #:mutable? #t '(1 2 3)) +(list->set #:weak? #t '(1 2 3)) +(list->set #:compare 'eqv '(1 2 3)) +] + +} + +@defproc[(custom-set [#:compare compare (-> any/c any/c any/c)] + [#:hash hash (-> any/c exact-integer?) (lambda (x) 0)] + [#:hash2 hash2 (-> any/c exact-integer?) (lambda (x) 0)] + [#:mutable? mutable? boolean? weak?] + [#:weak? weak? boolean? #f] + [elem any/c] ...) + set?]{ + +Produces a custom hash table-based set using the given equality predicate +@scheme[equiv?] and optional hash functions @scheme[hash-primary] and +@scheme[hash-secondary]. If no hash functions are given, they default to a +degenerate hash function, resulting in an effectively list-based set. The set +is populated with the given @scheme[elem] values. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(define singularity + (custom-set 'one 'two 'three + #:mutable? #t + #:compare (lambda (a b) #t))) +(set->list singularity) +(set-insert! singularity 'four) +(set->list singularity) +(set-remove! singularity 'zero) +(set->list singularity) +] + +} + +@section{Set Accessors} + +@defproc[(set-contains? [s set?] [x any/c]) boolean?]{ + +Reports whether @scheme[s] contains @scheme[x]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-contains? (set 1 2 3) 1) +(set-contains? (set 1 2 3) 4) +] + +} + +@defproc[(set-empty? [s set?]) boolean?]{ + +Reports whether a set is empty. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-empty? '()) +(set-empty? '((1 . one))) +] + +} + +@defproc[(set-count [s set?]) exact-nonnegative-integer?]{ + +Reports the number of elements in @scheme[s]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-count (set)) +(set-count (set 1 2 3)) +] + +} + +@defproc[(set=? [a set?] [b set?]) boolean?]{ + +Reports whether two sets contain the same elements. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set=? (set 1) (set 1 2 3)) +(set=? (set 1 2 3) (set 1)) +(set=? (set 1 2 3) (set 1 2 3)) +] + +} + +@defproc[(subset? [a set?] [b set?]) boolean?]{ + +Reports whether @scheme[b] contains all of the elements of @scheme[a]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(subset? (set 1) (set 1 2 3)) +(subset? (set 1 2 3) (set 1)) +(subset? (set 1 2 3) (set 1 2 3)) +] + +} + +@defproc[(proper-subset? [a set?] [b set?]) boolean?]{ + +Reports whether @scheme[b] contains all of the elements of @scheme[a], and at +least one element not in @scheme[a]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(proper-subset? (set 1) (set 1 2 3)) +(proper-subset? (set 1 2 3) (set 1)) +(proper-subset? (set 1 2 3) (set 1 2 3)) +] + +} + +@defproc[(set->list [s set?]) list?]{ + +Produces a list containing the elements of @scheme[s]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set->list (set 1 2 3)) +] + +} + +@defproc[(in-set [s set?]) sequence?]{ + +Produces a sequence iterating over the elements of the set. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(for/list ([x (in-set (set 1 2 3))]) x) +] + +} + +@section{Set Updaters} + +@defproc[(set-insert [s set?] [x any/c]) set?]{ + +Produces a new version of @scheme[s] containing @scheme[x]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-insert (set 1 2 3) 4) +(set-insert (set 1 2 3) 1) +] + +} + +@defproc[(set-remove [s set?] [x any/c]) set?]{ + +Produces a new version of @scheme[s] that does not contain @scheme[x]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-remove (set 1 2 3) 1) +(set-remove (set 1 2 3) 4) +] + +} + +@defproc[(set-insert! [s set?] [x any/c]) void?]{ + +Mutates @scheme[s] to contain @scheme[x]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(define s (set #:mutable? #t 1 2 3)) +s +(set-insert! s 4) +s +(set-insert! s 1) +s +] + +} + +@defproc[(set-remove! [s set?] [x any/c]) void?]{ + +Mutates @scheme[x] so as not to contain @scheme[x]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(define s (set #:mutable? #t 1 2 3)) +s +(set-remove! s 1) +s +(set-remove! s 4) +s +] + +} + +@defproc[(set-union [s0 (and/c set? set-can-insert?)] [s set?] ...) set?]{ + +Produces a new version of @scheme[s0] containing all the elements in each +@scheme[s]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-union (set 1 2) (set 1 3) (set 2 3)) +] + +} + +@defproc[(set-intersection [s0 (and/c set? set-can-remove?)] [s set?] ...) + set?]{ + +Produces a new version of @scheme[s0] containing only those elements found in +every @scheme[s]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-intersection (set 1 2 3) (set 1 2) (set 2 3)) +] + +} + +@defproc[(set-difference [s0 (and/c set? set-can-remove?)] [s set?] ...) set?]{ + +Produces a new version of @scheme[s0] containing only those elements not found +in any @scheme[s]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-difference (set 1 2 3) (set 1) (set 3)) +] + +} + +@defproc[(set-exclusive-or [s0 (and/c set? set-can-insert? set-can-remove?)] + [s set?] ...) + set?]{ + +Produces a new version of @scheme[s0] containing only those elements found in +@scheme[s0] and each @scheme[s] an odd number of times. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set-exclusive-or (set 1) (set 1 2) (set 1 2 3)) +] + +} + +@section{Set Predicates} + +@defproc[(set? [x any/c]) boolean?]{ + +Recognizes sets. A @deftech{set} is either a @tech[#:doc '(lib +"scribblings/reference/reference.scrbl")]{dictionary} or a structure with the +@scheme[prop:set] property. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(set? '(1 2)) +(set? '((1 . one) (2 . two))) +] + +} + +@deftogether[( +@defproc[(set-can-insert? [s set?]) boolean?] +@defproc[(set-can-remove? [s set?]) boolean?] +@defproc[(set-can-insert!? [s set?]) boolean?] +@defproc[(set-can-remove!? [s set?]) boolean?] +)]{ + +Report whether @scheme[s] supports @scheme[set-insert], @scheme[set-remove], +@scheme[set-insert!], or @scheme[set-remove!], respectively. + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(define functional-set (set 1 2 3)) +(set-can-insert? functional-set) +(set-can-remove? functional-set) +(set-can-insert!? functional-set) +(set-can-remove!? functional-set) +(define imperative-set (set #:mutable? #t 1 2 3)) +(set-can-insert? imperative-set) +(set-can-remove? imperative-set) +(set-can-insert!? imperative-set) +(set-can-remove!? imperative-set) +] + +} + +@section{Structures as Sets} + +@defthing[prop:set struct-type-property?]{ + +Property for structurs as @tech{sets}. Its value must be a vector of 7 +elements, as follows: + +@itemlist[ + +@item{a binary function implementing @scheme[set-contains?],} + +@item{a binary function implementing @scheme[set-insert!], or @scheme[#f] if not +supported,} + +@item{a binary function implementing @scheme[set-insert], or @scheme[#f] if not +supported,} + +@item{a binary function implementing @scheme[set-remove!], or @scheme[#f] if not +supported,} + +@item{a binary function implementing @scheme[set-remove], or @scheme[#f] if +not supported,} + +@item{a unary function implementing @scheme[set-count],} + +@item{and a unary function implementing @scheme[in-set].} + +] + +@defexamples[ +#:eval (evaluator 'unstable/cce/set) +(define (never-contains? set elem) #f) +(define (never-insert! set elem) (error 'set-insert! "always empty!")) +(define (never-insert set elem) (error 'set-insert "always empty!")) +(define (never-remove! set elem) (void)) +(define (never-remove set elem) set) +(define (always-zero set) 0) +(define (no-elements set) null) + +(define-struct always-empty [] + #:transparent + #:property prop:set + (vector never-contains? + never-insert! + never-insert + never-remove! + never-remove + always-zero + no-elements)) + +(set? (make-always-empty)) +(set-contains? (make-always-empty) 1) +(set-insert! (make-always-empty) 2) +(set-insert (make-always-empty) 3) +(set-remove (make-always-empty) 4) +(set-remove! (make-always-empty) 5) +(set-count (make-always-empty)) +(for ([x (in-set (make-always-empty))]) + (printf "~s\n" x)) +] + +} diff --git a/collects/unstable/cce/reference/slideshow.scrbl b/collects/unstable/cce/reference/slideshow.scrbl new file mode 100644 index 0000000000..9d7d22334b --- /dev/null +++ b/collects/unstable/cce/reference/slideshow.scrbl @@ -0,0 +1,314 @@ +#lang scribble/doc +@(require scribble/manual + "../scribble.ss" + (for-label slideshow + unstable/cce/contract + unstable/cce/slideshow)) + +@title[#:style 'quiet #:tag "cce-slideshow"]{Slideshow Presentations} + +@defmodule[unstable/cce/slideshow] + +@section{Text Formatting} + +@defform[(with-size size expr)]{ + +Sets @scheme[current-font-size] to @scheme[size] while running @scheme[expr]. + +} + +@defform[(with-scale scale expr)]{ + +Multiplies @scheme[current-font-size] by @scheme[scale] while running +@scheme[expr]. + +} + +@deftogether[( +@defform[(big text)] +@defform[(small text)] +)]{ + +Scale @scheme[current-font-size] by @scheme[3/2] or @scheme[2/3], respectively, +while running @scheme[text]. + +} + +@defform[(with-font font expr)]{ + +Sets @scheme[current-main-font] to @scheme[font] while running @scheme[expr]. + +} + +@defform[(with-style style expr)]{ + +Adds @scheme[style] to @scheme[current-main-font] (via @scheme[cons]) while +running @scheme[expr]. + +} + +@deftogether[( +@defform[(bold text)] +@defform[(italic text)] +@defform[(subscript text)] +@defform[(superscript text)] +@defform[(caps text)] +)]{ + +Adds the attributes for bold, italic, superscript, subscript, or small caps +text, respectively, to @scheme[current-main-font] while running @scheme[text]. + +} + +@section{Pict Colors} + +@defproc[(color [c color/c] [p pict?]) pict?]{ + +Applies color @scheme[c] to picture @scheme[p]. Equivalent to @scheme[(colorize +p c)]. + +} + +@deftogether[( +@defproc[(red [pict pict?]) pict?] +@defproc[(orange [pict pict?]) pict?] +@defproc[(yellow [pict pict?]) pict?] +@defproc[(green [pict pict?]) pict?] +@defproc[(blue [pict pict?]) pict?] +@defproc[(purple [pict pict?]) pict?] +@defproc[(black [pict pict?]) pict?] +@defproc[(brown [pict pict?]) pict?] +@defproc[(gray [pict pict?]) pict?] +@defproc[(white [pict pict?]) pict?] +@defproc[(cyan [pict pict?]) pict?] +@defproc[(magenta [pict pict?]) pict?] +)]{ + +These functions apply appropriate colors to picture @scheme[p]. + +} + +@deftogether[( +@defproc[(light [color color/c]) color/c] +@defproc[(dark [color color/c]) color/c] +)]{ + +These functions produce ligher or darker versions of a color. + +} + +@defthing[color/c flat-contract?]{ + +This contract recognizes color strings, @scheme[color%] instances, and RGB color +lists. + +} + +@section{Pict Manipulation} + +@defproc[(fill [pict pict?] [width (or/c real? #f)] [height (or/c real? #f)]) + pict?]{ + +Extends @scheme[pict]'s bounding box to a minimum @scheme[width] and/or +@scheme[height], placing the original picture in the middle of the space. + +} + +@subsection{Conditional Manipulations} + +These pict transformers all take boolean arguments that determine whether to +transform the pict or leave it unchanged. These transformations can be useful +for staged slides, as the resulting pict always has the same size and shape, and +its contents always appear at the same position, but changing the boolean +argument between slides can control when the transformation occurs. + +@deftogether[( +@defproc[(show [pict pict?] [show? truth/c #t]) pict?] +@defproc[(hide [pict pict?] [hide? truth/c #t]) pict?] +)]{ + +These functions conditionally show or hide an image, essentially choosing +between @scheme[pict] and @scheme[(ghost pict)]. The only difference between +the two is the default behavior and the opposite meaning of the @scheme[show?] +and @scheme[hide?] booleans. Both functions are provided for mnemonic purposes. + +} + +@defproc[(strike [pict pict?] [strike? truth/c #t]) pict?]{ + +Displays a strikethrough image by putting a line through the middle of +@scheme[pict] if @scheme[strike?] is true; produces @scheme[pict] unchanged +otherwise. + +} + +@defproc[(shade [pict pict?] + [shade? truth/c #t] + [#:ratio ratio (real-in 0 1) 1/2]) + pict?]{ + +Shades @scheme[pict] to show with @scheme[ratio] of its normal opacity; if +@scheme[ratio] is @scheme[1] or @scheme[shade?] is @scheme[#f], shows +@scheme[pict] unchanged. + +} + +@subsection{Conditional Combinations} + +These pict control flow operators decide which pict of several to use. All +branches are evaluated; the resulting pict is a combination of the pict chosen +by normal conditional flow with @scheme[ghost] applied to all the other picts. +The result is a picture large enough to accomodate each alternative, but showing +only the chosen one. This is useful for staged slides, as the pict chosen may +change with each slide but its size and position will not. + +@defform/subs[(pict-if maybe-combine test-expr then-expr else-expr) + ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ + +Chooses either @scheme[then-expr] or @scheme[else-expr] based on +@scheme[test-expr], similarly to @scheme[if]. Combines the chosen, visible +image with the other, invisible image using @scheme[combine-expr], defaulting to +@scheme[pict-combine]. + +} + +@defform/subs[(pict-cond maybe-combine [test-expr pict-expr] ...) + ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ + +Chooses a @scheme[pict-expr] based on the first successful @scheme[test-expr], +similarly to @scheme[cond]. Combines the chosen, visible image with the other, +invisible images using @scheme[combine-expr], defaulting to +@scheme[pict-combine]. + +} + +@defform/subs[(pict-case test-expr maybe-combine [literals pict-expr] ...) + ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ + +Chooses a @scheme[pict-expr] based on @scheme[test-expr] and each list of +@scheme[literals], similarly to @scheme[case]. Combines the chosen, visible +image with the other, invisible images using @scheme[combine-expr], defaulting +to @scheme[pict-combine]. + +} + +@defform/subs[(pict-match test-expr maybe-combine [pattern pict-expr] ...) + ([maybe-combine code:blank (code:line #:combine combine-expr)])]{ + +Chooses a @scheme[pict-expr] based on @scheme[test-expr] and each +@scheme[pattern], similarly to @scheme[match]. Combines the chosen, visible +image with the other, invisible images using @scheme[combine-expr], defaulting +to @scheme[pict-combine]. + +} + +@defform[#:id pict-combine pict-combine]{ + +This syntax parameter determines the default pict combining form used by the +above macros. It defaults to @scheme[lbl-superimpose]. + +} + +@defform[(with-pict-combine combine-id body ...)]{ + +Sets @scheme[pict-combine] to refer to @scheme[combine-id] within each of the +@scheme[body] terms, which are spliced into the containing context. + +} + +@section{Staged Slides} + +@defform[(staged [name ...] body ...)]{ + +Executes the @scheme[body] terms once for each stage @scheme[name]. The terms +may include expressions and mutually recursive definitions. Within the body, +each @scheme[name] is bound to a number from @scheme[1] to the number of stages +in order. Furthermore, during execution @scheme[stage] is bound to the number +of the current stage and @scheme[stage-name] is bound to a symbol representing +the @scheme[name] of the current stage. By comparing @scheme[stage] to the +numeric value of each @scheme[name], or @scheme[stage-name] to quoted symbols of +the form @scheme['name], the user may compute based on the progression of the +stages. + +} + +@deftogether[( +@defform[#:id stage stage] +@defform[#:id stage-name stage-name] +)]{ + +These keywords are bound during the execution of @scheme[staged] and should not +be used otherwise. + +} + +@defform[(slide/staged [name ...] arg ...)]{ + +Creates a staged slide. Equivalent to @scheme[(staged [name ...] (slide arg +...))]. + +Within a staged slide, the boolean arguments to @scheme[hide], @scheme[show], +@scheme[strike], and @scheme[shade] can be used to determine in which stages to +perform a transformation. The macros @scheme[pict-if], @scheme[pict-cond], +@scheme[pict-case], and @scheme[pict-match] may also be used to create images +which change naturally between stages. + +} + +@section{Tables} + +@defproc[(tabular [row (listof (or/c string? pict?))] ... + [#:gap gap natural-number/c gap-size] + [#:hgap hgap natural-number/c gap] + [#:vgap vgap natural-number/c gap] + [#:align align (->* [] [] #:rest (listof pict?) pict?) lbl-superimpose] + [#:halign halign (->* [] [] #:rest (listof pict?) pict?) align] + [#:valign valign (->* [] [] #:rest (listof pict?) pict?) align]) + pict?]{ + +Constructs a table containing the given @scheme[row]s, all of which must be of +the same length. Applies @scheme[t] to each string in a @scheme[row] to +construct a pict. The @scheme[hgap], @scheme[vgap], @scheme[halign], and +@scheme[valign] are used to determine the horizontal and vertical gaps and +alignments as in @scheme[table] (except that every row and column is uniform). + +} + +@section{Multiple Columns} + +@defform[(two-columns one two)]{ + +Constructs a two-column pict using @scheme[one] and @scheme[two] as the two +columns. Sets @scheme[current-para-width] appropriately in each column. + +} + +@defproc[(mini-slide [pict pict?] ...) pict?]{ + +Appends each @scheme[pict] vertically with space between them, similarly to the +@scheme[slide] function. + +} + +@defproc[(columns [pict pict?] ...) pict?]{ + +Combines each @scheme[pict] horizontally, aligned at the top, with space in +between. + +} + +@defform[(column width body ...)]{ + +Sets @scheme[current-para-width] to @scheme[width] during execution of the +@scheme[body] expressions. + +} + +@defproc[(column-size [n exact-positive-integer?] + [r real? (/ n )]) + real?]{ + +Computes the width of one column out of @scheme[n] that takes up a ratio of +@scheme[r] of the available space (according to @scheme[current-para-width]). + +} diff --git a/collects/unstable/cce/reference/syntax.scrbl b/collects/unstable/cce/reference/syntax.scrbl new file mode 100644 index 0000000000..8fa0d2cb1d --- /dev/null +++ b/collects/unstable/cce/reference/syntax.scrbl @@ -0,0 +1,387 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/syntax)) + +@title[#:style 'quiet #:tag "cce-syntax"]{Syntax Objects} + +@defmodule[unstable/cce/syntax] + +This module provides tools for macro transformers. + +@section{Contracts} + +@defproc[(syntax-datum/c [datum/c any/c]) flat-contract?]{ + +Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->datum stx)] +satisfies @scheme[datum/c]. + +} + +@defproc[(syntax-listof/c [elem/c any/c]) flat-contract?]{ + +Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)] +satisfies @scheme[(listof elem/c)]. + +} + +@defproc[(syntax-list/c [elem/c any/c] ...) flat-contract?]{ + +Recognizes syntax objects @scheme[stx] such that @scheme[(syntax->list stx)] +satisfies @scheme[(list/c elem/c ...)]. + +} + +@section{Syntax Lists} + +@defform[(syntax-list template ...)]{ + +This form constructs a list of syntax objects based on the given templates. It +is equivalent to @scheme[(syntax->list (syntax (template ...)))]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(with-syntax ([(x ...) (syntax (1 2 3))]) (syntax-list x ...)) +] + +} + +@defproc[(syntax-map [f (-> syntax? A)] [stx syntax?]) (listof A)]{ + +Performs @scheme[(map f (syntax->list stx))]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(syntax-map syntax-e #'(a (b c) d)) +] + +} + +@section{Syntax Conversions} + +@defproc[(to-syntax [datum any/c] + [#:stx stx (or/c false/c syntax?) #f] + [#:src src src/c stx] + [#:ctxt ctxt (or/c false/c syntax?) stx] + [#:prop prop (or/c false/c syntax?) stx] + [#:cert cert (or/c false/c syntax?) stx]) + syntax?]{ + +A wrapper for @scheme[datum->syntax] with keyword arguments. + +The "master" keyword @scheme[#:stx] sets all attributes from a single syntax +object, defaulting to @scheme[#f] for unadorned syntax objects. + +The individual keywords @scheme[#:src], @scheme[#:ctxt], @scheme[#:prop], and +@scheme[#:cert] override @scheme[#:stx] for individual syntax object +attributes. They control source src information, lexical context +information, syntax object properties, and syntax certificates, respectively. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(define blank-stx (to-syntax 'car)) +blank-stx +(syntax-e blank-stx) +(free-identifier=? blank-stx #'car) +(define full-stx (to-syntax 'car #:stx #'here)) +full-stx +(syntax-e full-stx) +(free-identifier=? full-stx #'car) +(define partial-stx (to-syntax 'car #:ctxt #'here)) +partial-stx +(syntax-e partial-stx) +(free-identifier=? partial-stx #'car) +] + +} + +@defproc[(to-datum [x any/c]) (not/c syntax?)]{ + +A wrapper for @scheme[syntax->datum]. Produces @scheme[(syntax->datum x)] if +@scheme[x] is a syntax object and @scheme[x] otherwise. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(to-datum #'(a b c)) +(to-datum (list #'a #'b #'c)) +] + +} + +@section{Source Locations [Deprecated]} + +@subsection{Source Location Representations} + +@defthing[src/c flat-contract?]{ + +This contract recognizes various representations of source locations, including +@scheme[srcloc] structures and those accepted by @scheme[datum->syntax]: syntax +objects, source location lists, source location vectors, and @scheme[#f]. + +} + +@deftogether[( +@defproc[(src->srcloc [loc src/c] ...) srcloc?] +@defproc[(src->syntax [loc src/c] ...) syntax?] +@defproc[(src->list [loc src/c] ...) + (list/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f))] +@defproc[(src->vector [loc src/c] ...) + (vector/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f))] +)]{ + +These functions combine multiple source locations and convert them to a specific +format. If all provided source locations come from the same source, the result +is a source location from the same source that spans all the lines, columns, and +positions included in the originals. If no source locations are provided, or +locations from different sources are provided, the result is a source location +with no information (@scheme[#f] for source, line, column, position, and span). + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(src->srcloc (datum->syntax #f null (list 'source 2 3 4 5))) +(src->syntax (make-srcloc 'source 2 3 4 5)) +(src->list (list 'source 2 3 4 5) (vector 'source 6 7 8 9)) +(src->vector) +] + +} + +@defproc[(src-known? [loc src/c]) boolean?]{ + +Reports whether @scheme[loc] has any non-@scheme[#f] fields. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(src-known? (list #f #f #f #f #f)) +(src-known? (list 'source #f #f #f #f)) +(src-known? (list 'source 1 2 3 4)) +] + +} + +@subsection{Syntax Object Source Locations} + +@deftogether[( +@defproc[(syntax-source-directory [stx syntax?]) (or/c path? #f)] +@defproc[(syntax-source-file-name [stx syntax?]) (or/c path? #f)] +)]{ + +These produce the directory and file name, respectively, of the path with which +@scheme[stx] is associated, or @scheme[#f] if @scheme[stx] is not associated +with a path. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(define loc + (list (build-path "/tmp" "dir" "somewhere.ss") + #f #f #f #f)) +(define stx1 (datum->syntax #f 'somewhere loc)) +(syntax-source-directory stx1) +(syntax-source-file-name stx1) +(define stx2 (datum->syntax #f 'nowhere #f)) +(syntax-source-directory stx2) +(syntax-source-directory stx2) +] + +} + +@deftogether[( +@defproc[(syntax-source-planet-package [stx syntax?]) + (or/c (list/c string? + string? + exact-nonnegative-integer? + exact-nonnegative-integer?) + #f)] +@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)] +@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)] +@defproc[(syntax-source-planet-package-major [stx syntax?]) + (or/c exact-nonnegative-integer? #f)] +@defproc[(syntax-source-planet-package-minor [stx syntax?]) + (or/c exact-nonnegative-integer? #f)] +@defproc[(syntax-source-planet-package-symbol + [stx syntax?] + [text (or/c text? #f) #f]) + (or/c symbol? #f)] +)]{ + +These functions extract the planet package with which @scheme[stx] is +associated, if any, based on its source location information and the currently +installed set of planet packages. They produce, respectively, the planet +package s-expression, its owner, name, major version number, minor version +number, or a symbol corresponding to a @scheme[planet] module path. They each +produce @scheme[#f] if @scheme[stx] is not associated with a planet package. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(define loc + (list (build-path (current-directory) "file.ss") + #f #f #f #f)) +(define stx (datum->syntax #f 'stx loc)) +(syntax-source-planet-package stx) +(syntax-source-planet-package-owner stx) +(syntax-source-planet-package-name stx) +(syntax-source-planet-package-major stx) +(syntax-source-planet-package-minor stx) +(syntax-source-planet-package-symbol stx) +(syntax-source-planet-package-symbol stx "there") +] + +} + +@defproc[(make-planet-path [stx syntax?] [id (or/c identifier? #f)]) syntax?]{ + +Constructs a syntax object representing a require spec for the planet package +from which @scheme[stx] arises, with suffix @scheme[id] (if any). + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(define loc + (list (build-path (current-directory) "file.ss") + #f #f #f #f)) +(define stx (datum->syntax #f 'stx loc)) +(make-planet-path stx #f) +(make-planet-path stx #'there) +] + +} + +@section{Macro Transformers} + +@defproc[(redirect-transformer [id identifier?]) (-> syntax? syntax?)]{ + +Constructs a function that behaves like a rename transformer; it does not +cooperate with @scheme[syntax-local-value] like a rename transformer does, but +unlike a rename transformer it may be used as a function to transform a syntax +object referring to one identifier into a syntax object referring to another. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +((redirect-transformer #'x) #'a) +((redirect-transformer #'y) #'(a b c)) +] + +} + +@defproc[(head-expand [stx syntax?] [stop-list (listof identifier?)]) syntax?]{ + +This function performs head expansion on @scheme[stx]. In other words, it uses +@scheme[local-expand] to expand @scheme[stx] until its head identifier is a core +form (a member of @scheme[(full-kernel-form-identifier-list)]) or a member of +@scheme[stop-list], or until it can not be expanded further (e.g. due to error). + +It is equivalent to @scheme[(local-expand stx (syntax-local-context) (append +stop-ids (full-kernel-form-identifier-list) #f))]. + +} + +@defproc[(full-kernel-form-identifier-list) (listof identifier?)]{ + +This function produces the full list of identifiers that may be found in fully +expanded code produced by @scheme[expand], @scheme[local-expand], and related +functions. It is similar to @scheme[kernel-form-identifier-list], except that +in prior versions of PLT Scheme that excluded module top-level forms from the +list, this function includes them. + +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(full-kernel-form-identifier-list) +] + +} + +@defproc[(trampoline-transformer + [f (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?)]) + (-> syntax? syntax?)]{ + +Produces a transformer that can emit multiple results during macro expansion, to +be spliced together via @scheme[begin]. This can be useful for compound +expansion that relies on transformer definitions, as well as on expansion state +that is difficult to marshall. + +Specifically, @scheme[f] is invoked with three arguments. The first is the +function used to emit intermediate results (other than the last one). The +second applies the @tech[#:doc '(lib +"scribblings/reference/reference.scrbl")]{syntax mark} used for the entire +expansion; @scheme[syntax-local-introduce] will not be reliable during this +process. The third is the syntax object to expand. + +@defexamples[ +#:eval (evaluator '(for-syntax unstable/cce/syntax)) +(define-syntax magic-begin + (trampoline-transformer + (lambda (emit intro stx) + (syntax-case stx () + [(_ term ...) + (let loop ([terms (syntax->list #'(term ...))]) + (cond + [(null? terms) #'(begin)] + [(null? (cdr terms)) (car terms)] + [else + (printf "Presto: ~s!\n" + (syntax->datum (car terms))) + (emit (car terms)) + (loop (cdr terms))]))])))) +(magic-begin + (define x 1) + (define y 2) + (+ x y)) +] + +} + +@defproc[(quote-transformer [x any/c]) syntax?]{ + +Produces a syntax object representing an expression that reconstructs @scheme[x] +when executed, including faithfully reconstructing any syntax objects contained +in @scheme[x]. Note that @scheme[quote] normally converts syntax objects to +non-syntax data, and @scheme[quote-syntax] does the opposite. + +@defexamples[ +#:eval (evaluator '(for-syntax unstable/cce/syntax)) +(define-for-syntax x (list 1 #'(2 3) 4)) +(define-syntax (the-many-faces-of-x stx) + (with-syntax ([x x] [qx (quote-transformer x)]) + #'(list (quote x) + (quote-syntax x) + qx))) +(the-many-faces-of-x) +] + +} + +@section{Syntax Errors} + +@defthing[current-syntax (parameter/c (or/c syntax? false/c))]{ +A parameter that may be used to store the current syntax object being +transformed. It is not used by the expander; you have to assign to it yourself. +This parameter is used by @scheme[syntax-error], below. It defaults to +@scheme[#f]. +} + +@defproc[(syntax-error [stx syntax?] [fmt string?] [arg any/c] ...) none/c]{ +Raises a syntax error based on the locations of @scheme[(current-syntax)] and +@scheme[stx], with @scheme[(format fmt arg ...)] as its message. +@defexamples[ +#:eval (evaluator 'unstable/cce/syntax) +(define stx #'(a b c)) +(parameterize ([current-syntax #f]) + (syntax-error stx "~s location" 'general)) +(parameterize ([current-syntax stx]) + (syntax-error (car (syntax-e stx)) "~s location" 'specific)) +] +} + +@section{Pattern Bindings} + +This package re-exports @scheme[with-syntax*] from +@schememodname[unstable/syntax]. diff --git a/collects/unstable/cce/reference/text.scrbl b/collects/unstable/cce/reference/text.scrbl new file mode 100644 index 0000000000..11f18d613a --- /dev/null +++ b/collects/unstable/cce/reference/text.scrbl @@ -0,0 +1,170 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/text)) + +@title[#:style 'quiet #:tag "cce-text"]{Text Representations} + +@defmodule[unstable/cce/text] + +This module provides tools for manipulating and converting textual data. + +@section{Contracts and Predicates} + +@deftogether[( +@defthing[text/c flat-contract?]{} +@defproc[(text? [v any/c]) boolean?]{} +)]{ + +This contract and predicate recognize text values: strings, byte strings, +symbols, and keywords, as well as syntax objects containing them. + +@defexamples[ +#:eval (evaluator 'unstable/cce/text) +(text? "text") +(text? #"text") +(text? 'text) +(text? '#:text) +(text? #'"text") +(text? #'#"text") +(text? #'text) +(text? #'#:text) +(text? '(not text)) +] + +} + +@deftogether[( +@defproc[(string-literal? [v any/c]) boolean?]{} +@defproc[(bytes-literal? [v any/c]) boolean?]{} +@defproc[(keyword-literal? [v any/c]) boolean?]{} +)]{ + +These predicates recognize specific text types stored in syntax objects. + +@defexamples[ +#:eval (evaluator 'unstable/cce/text) +(string-literal? #'"literal") +(string-literal? "not literal") +(bytes-literal? #'#"literal") +(bytes-literal? #"not literal") +(keyword-literal? #'#:literal) +(keyword-literal? '#:not-literal) +] + +} + +@section{Text Conversions and Concatenation} + +@deftogether[( +@defproc[(text->string [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [text text/c] ...) string?]{} +@defproc[(text->bytes [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [text text/c] ...) bytes?]{} +@defproc[(text->symbol [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [text text/c] ...) symbol?]{} +@defproc[(text->keyword [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [text text/c] ...) keyword?]{} +)]{ + +These functions convert text values to specific types. They concatenate each +@scheme[text] argument, adding @scheme[before] and @scheme[after] to the front +and back of the result and @scheme[between] between each argument. + +@defexamples[ +#:eval (evaluator 'unstable/cce/text) +(text->string #"concat" #'enate) +(text->bytes #:between "-" 'concat #'#:enate) +(text->symbol #:before "(" #:after ")" '#:concat #'"enate") +(text->keyword #:before #'< #:between #'- #:after #'> "concat" #'#"enate") +] + +} + +@deftogether[( +@defproc[(text->string-literal [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [#:stx stx (or/c syntax? false/c) #f] + [text text/c] ...) + string-literal?]{} +@defproc[(text->bytes-literal [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [#:stx stx (or/c syntax? false/c) #f] + [text text/c] ...) + bytes-literal?]{} +@defproc[(text->identifier [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [#:stx stx (or/c syntax? false/c) #f] + [text text/c] ...) + identifier?]{} +@defproc[(text->keyword-literal [#:before before text/c ""] + [#:between between text/c ""] + [#:after after text/c ""] + [#:stx stx (or/c syntax? false/c) #f] + [text text/c] ...) + keyword-literal?]{} +)]{ + +These functions convert text values to specific syntax object types, deriving +syntax object properties from the @scheme[stx] argument. They concatenate each +@scheme[text] argument, adding @scheme[before] and @scheme[after] to the front +and back of the result and @scheme[between] between each argument. + +@defexamples[ +#:eval (evaluator 'unstable/cce/text) +(text->string-literal #"concat" #'enate) +(text->bytes-literal #:between "-" 'concat #'#:enate) +(text->identifier #:before "(" #:after ")" + #:stx #'props + '#:concat #'"enate") +(text->keyword-literal #:before #'< #:between #'- #:after #'> + #:stx #'props + "concat" #'#"enate") +] + +} + +@section{Text Comparisons} + +@deftogether[( +@defproc[(text=? [one text/c] [two text/c]) boolean?] +@defproc[(text? [one text/c] [two text/c]) boolean?] +@defproc[(text>=? [one text/c] [two text/c]) boolean?] +)]{ + +These predicates compare the character content of two text values. They are +equivalent to: + +@schemeblock[ +(text=? one two) = (string=? (text->string one) (text->string two)) +(textstring one) (text->string two)) +(text<=? one two) = (string<=? (text->string one) (text->string two)) +(text>? one two) = (string>? (text->string one) (text->string two)) +(text>=? one two) = (string>=? (text->string one) (text->string two)) +] + +@defexamples[ +#:eval (evaluator 'unstable/cce/text) +(text=? #"x" #'y) +(text? #"x" #'y) +(text>=? #"x" #'y) +] + +} diff --git a/collects/unstable/cce/reference/values.scrbl b/collects/unstable/cce/reference/values.scrbl new file mode 100644 index 0000000000..4c4caa0da2 --- /dev/null +++ b/collects/unstable/cce/reference/values.scrbl @@ -0,0 +1,86 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme unstable/cce/values)) + +@title[#:style 'quiet #:tag "cce-values"]{Multiple Values} + +@defmodule[unstable/cce/values] + +This module provides tools for manipulating functions and expressions that +produce multiple values. + +@defform[(values->list expr)]{ + +Produces a list of the values returned by @scheme[expr]. + +@defexamples[ +#:eval (evaluator 'unstable/cce/values) +(values->list (values 1 2 3)) +] + +} + +@defproc[(map2 [f (-> A ... (values B C))] [lst (listof A)] ...) + (values (listof B) (listof C))]{ + +Produces a pair of lists of the respective values of @scheme[f] applied to the +elements in @scheme[lst ...] sequentially. + +@defexamples[ +#:eval (evaluator 'unstable/cce/values) +(map2 (lambda (x) (values (+ x 1) (- x 1))) (list 1 2 3)) +] + +} + +@defproc[(map/values [n natural-number/c] + [f (-> A ... (values B_1 ... B_n))] + [lst (listof A)] + ...) + (values (listof B_1) ... (listof B_n))]{ + +Produces lists of the respective values of @scheme[f] applied to the elements in +@scheme[lst ...] sequentially. + +@defexamples[ +#:eval (evaluator 'unstable/cce/values) +(map/values + 3 + (lambda (x) + (values (+ x 1) x (- x 1))) + (list 1 2 3)) +] + +} + +@deftogether[( +@defproc[(foldr/values [f (-> A ... B ... (values B ...))] + [vs (list/c B ...)] + [lst (listof A)] + ...) + (values B ...)] +@defproc[(foldl/values [f (-> A ... B ... (values B ...))] + [vs (list/c B ...)] + [lst (listof A)] + ...) + (values B ...)] +)]{ + +These functions combine the values in the lists @scheme[lst ...] using the +multiple-valued function @scheme[f]; @scheme[foldr/values] traverses the lists +right to left and @scheme[foldl/values] traverses left to right. + +@defexamples[ +#:eval (evaluator 'unstable/cce/values) +(define (add/cons a b c d) + (values (+ a c) (cons b d))) +(foldr/values add/cons (list 0 null) + (list 1 2 3 4) (list 5 6 7 8)) +(foldl/values add/cons (list 0 null) + (list 1 2 3 4) (list 5 6 7 8)) +] + +} diff --git a/collects/unstable/cce/reference/web.scrbl b/collects/unstable/cce/reference/web.scrbl new file mode 100644 index 0000000000..1481a9f8d4 --- /dev/null +++ b/collects/unstable/cce/reference/web.scrbl @@ -0,0 +1,58 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + "../scribble.ss" + "eval.ss") +@(require (for-label scheme xml unstable/cce/web)) + +@title[#:style 'quiet #:tag "cce-web"]{XML and CSS} + +@defmodule[unstable/cce/web] + +This module provides tools for programmatic creation of static web pages. It is +based on the XML collection; see documentation for @scheme[xexpr?]. + +@deftogether[( +@defthing[css/c flat-contract?] +@defproc[(css? [v any/c]) boolean?] +)]{ +This contract and predicate pair recognizes CSS-expressions, which are +described by the following grammar: + +@schemegrammar*[ +#:literals (cons list) +[css (list style ...)] +[style-def (cons selector (list property ...))] +[property (list name value)] +[selector text] +[name text] +[value text] +] + +Here, @scheme[text] is any of the datatypes described in @secref["cce-text"]. +} + +@defthing[xexpr/c flat-contract?]{ +This flat contract corresponds to @scheme[xexpr?]. It is reprovided from +@schememodname[xml]. In versions of PLT Scheme before the implementation of +@scheme[xexpr/c], this module provides its own definition. +} + +@deftogether[( +@defproc[(write-css [css css/c] [out output-port? (current-output-port)]) + void?] +@defproc[(write-xexpr [css css/c] [out output-port? (current-output-port)]) + void?] +)]{ +These functions write CSS-expressions and +X-expressions, respectively, to output ports, by their +canonical text representations. +} + +@deftogether[( +@defproc[(create-stylesheet [file path-string?] [css css/c]) void?] +@defproc[(create-webpage [file path-string?] [xexpr xexpr/c]) void?] +)]{ +These functions write style sheets (represented as CSS-expressions) or +webpages (represented as X-expressions) to files. +} diff --git a/collects/unstable/cce/regexp.ss b/collects/unstable/cce/regexp.ss new file mode 100644 index 0000000000..f7951f1191 --- /dev/null +++ b/collects/unstable/cce/regexp.ss @@ -0,0 +1,59 @@ +#lang scheme/base + +(require scheme/list scheme/contract) + +;; regexp-or : String ... -> String +;; Produces the regexp disjunction of several regexp-strings. +(define (regexp-or . strings) + (apply string-append (add-between strings "|"))) + +;; regexp-maybe : String ... -> String +;; Matches the sequence of regexps, or nothing. +(define (regexp-maybe . strings) + (format "(?:~a)?" (apply regexp-sequence strings))) + +;; regexp-star : String ... -> String +;; Matches zero or more occurrences of the sequence of regexps. +(define (regexp-star . strings) + (format "(?:~a)*" (apply regexp-sequence strings))) + +;; regexp-plus : String ... -> String +;; Matches one or more occurrences of the sequence of regexps. +(define (regexp-plus . strings) + (format "(?:~a)+" (apply regexp-sequence strings))) + +;; regexp-save : String ... -> String +;; Matches and records the matched text of the sequence of regexps. +(define (regexp-save . strings) + (format "(~a)" (apply regexp-sequence strings))) + +(define (regexp-group string) + (format "(?:~a)" string)) + +;; regexp-sequence +;; : String ... [#:start String #:end String #:between String] -> String +(define (regexp-sequence #:start [start ""] + #:end [end ""] + #:between [between ""] + . strings) + (apply string-append + (append (list start) + (add-between (map regexp-group strings) between) + (list end)))) + +;; regexp-multi : String ... -> String +;; Match a sequence of regexps in multi-line mode. +(define (regexp-multi . strings) + (format "(?m:~a)" (apply regexp-sequence strings))) + +(provide/contract + [regexp-sequence + (->* [] [#:start string? #:end string? #:between string?] + #:rest (listof string?) + string?)] + [regexp-or (->* [string?] [] #:rest (listof string?) string?)] + [regexp-maybe (->* [string?] [] #:rest (listof string?) string?)] + [regexp-star (->* [string?] [] #:rest (listof string?) string?)] + [regexp-plus (->* [string?] [] #:rest (listof string?) string?)] + [regexp-save (->* [string?] [] #:rest (listof string?) string?)] + [regexp-multi (->* [string?] [] #:rest (listof string?) string?)]) diff --git a/collects/unstable/cce/require-provide.ss b/collects/unstable/cce/require-provide.ss new file mode 100644 index 0000000000..efddb525e8 --- /dev/null +++ b/collects/unstable/cce/require-provide.ss @@ -0,0 +1,160 @@ +#lang scheme + +(require (for-syntax scheme/match + scheme/require-transform + scheme/provide-transform + syntax/parse + "syntax.ss") + "define.ss") + +(define-syntax (define-planet-package stx) + (syntax-parse stx + [(_ name:id pkg:id) + (syntax/loc stx + (define-syntax name + (make-require-transformer + (lambda (stx*) + (syntax-parse stx* + [(_) (expand-import (datum->syntax stx* (list #'planet #'pkg)))] + [(_ file:id) + (let* ([prefix (symbol->string (syntax-e #'pkg))] + [suffix (symbol->string (syntax-e #'file))] + [sym (string->symbol (string-append prefix "/" suffix))] + [spec (datum->syntax stx* (list #'planet sym))]) + (expand-import spec))])))))])) + +(define-syntax (define-collection stx) + (syntax-parse stx + [(_ name:id collect:id) + #'(define-syntax name + (make-require-transformer + (lambda (stx*) + (syntax-parse stx* + [(_) (expand-import (datum->syntax stx* (syntax-e #'collect)))] + [(_ file:id) + (let* ([prefix (symbol->string (syntax-e #'collect))] + [suffix (symbol->string (syntax-e #'file))] + [sym (string->symbol (string-append prefix "/" suffix))] + [spec (datum->syntax stx* sym)]) + (expand-import spec))]))))])) + +(define-syntax this-package-in + (make-require-transformer + (lambda (stx) + (syntax-parse stx + [(_ file:id) + (expand-import (make-planet-path stx #'file))])))) + +(define-syntax this-package-out + (make-provide-transformer + (lambda (stx modes) + (syntax-parse stx + [(_ file:id) + (expand-export + (datum->syntax + stx + (list #'all-from-out (make-planet-path stx #'file))) + modes)])))) + +(define-for-syntax (import->export i) + (make-export (import-local-id i) + (syntax-e (import-local-id i)) + (import-mode i) + #f + (import-orig-stx i))) + +(define-syntax box-require + (make-require-transformer + (lambda (stx) + (syntax-parse stx + [(_ ibox spec:expr) + #:declare ibox (static box? "mutable box for expanded import specs") + (let-values ([(imports sources) (expand-import #'spec)]) + (set-box! (syntax-local-value #'ibox) imports) + (values imports sources))])))) + +(define-syntax box-provide + (make-provide-transformer + (lambda (stx modes) + (syntax-parse stx + [(_ ibox) + #:declare ibox (static box? "mutable box for expanded import specs") + (map import->export (unbox (syntax-local-value #'ibox)))])))) + +(define-syntax-rule (require/provide spec ...) + (begin + (define-syntax imports (box #f)) + (require (box-require imports (combine-in spec ...))) + (provide (box-provide imports)))) + +(define-syntax (quote-require stx) + (syntax-parse stx + [(_ spec:expr ...) + (let*-values ([(imports sources) + (expand-import (syntax/loc stx (combine-in spec ...)))]) + (with-syntax ([(name ...) (map import-local-id imports)]) + (syntax/loc stx '(name ...))))])) + +;; rename-import : Import Identifier -> Import +;; Creates a new import that binds the given identifier, but otherwise acts as +;; the original import. +(define-for-syntax (rename-import i id) + (struct-copy import i [local-id id])) + +;; import->raw-require-spec : Import -> Syntax +;; Constructs a raw-require-spec (suitable for #%require) that should have the +;; same behavior as a require-spec that produces the given import. +(define-for-syntax (import->raw-require-spec i) + (match i + [(struct import [local-id + src-sym + src-mod-path + mode + req-mode + orig-mode + orig-stx]) + (datum->syntax + orig-stx + (list #'just-meta + req-mode + (list #'for-meta + mode + (list #'rename + src-mod-path + (syntax-local-introduce local-id) + src-sym))) + orig-stx)])) + +;; (do-local-require rename spec ...) +;; Lifts (require spec ...) to the (module) top level, and makes the imported +;; bindings available in the current context via a renaming macro. +(define-syntax (do-local-require stx) + (syntax-parse stx + [(_ rename:id spec:expr ...) + (let*-values ([(imports sources) + (expand-import + (datum->syntax + stx + (list* #'only-meta-in 0 (syntax->list #'(spec ...))) + stx))] + [(names) (map import-local-id imports)] + [(reqd-names) + (let ([ctx (syntax-local-get-shadower (datum->syntax #f (gensym)))]) + (map (lambda (n) (datum->syntax ctx (syntax-e n) n)) names))] + [(renamed-imports) (map rename-import imports reqd-names)] + [(raw-specs) (map import->raw-require-spec renamed-imports)] + [(lifts) (map syntax-local-lift-require raw-specs reqd-names)]) + (with-syntax ([(name ...) names] + [(lifted ...) lifts]) + (syntax/loc stx (rename [name lifted] ...))))])) + +(define-syntax-rule (local-require spec ...) + (do-local-require define-renamings spec ...)) + +(provide require/provide + do-local-require + local-require + quote-require + define-planet-package + define-collection + this-package-in) diff --git a/collects/unstable/cce/sandbox.ss b/collects/unstable/cce/sandbox.ss new file mode 100644 index 0000000000..27f51aee98 --- /dev/null +++ b/collects/unstable/cce/sandbox.ss @@ -0,0 +1,67 @@ +#lang scheme + +(require scheme/sandbox + "define.ss") + +(provide make-trusted-evaluator + make-trusted-module-evaluator + make-scribble-evaluator + make-scribble-module-evaluator + make-sandbox-namespace-specs) + +;; Needed for legacy versions of scheme/sandbox +(define-if-unbound (call-with-trusted-sandbox-configuration thunk) + (parameterize ([sandbox-propagate-breaks #t] + [sandbox-override-collection-paths '()] + [sandbox-security-guard (current-security-guard)] + [sandbox-make-inspector current-inspector] + [sandbox-make-logger current-logger] + [sandbox-eval-limits #f]) + (thunk))) + +(define make-trusted-evaluator + (make-keyword-procedure + (lambda (keys vals . args) + (call-with-trusted-sandbox-configuration + (lambda () + (keyword-apply make-evaluator keys vals args)))))) + +(define make-trusted-module-evaluator + (make-keyword-procedure + (lambda (keys vals . args) + (call-with-trusted-sandbox-configuration + (lambda () + (keyword-apply make-module-evaluator keys vals args)))))) + +(define make-scribble-evaluator + (make-keyword-procedure + (lambda (keys vals . args) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string]) + (keyword-apply make-trusted-evaluator keys vals args))))) + +(define make-scribble-module-evaluator + (make-keyword-procedure + (lambda (keys vals . args) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string]) + (keyword-apply make-trusted-module-evaluator keys vals args))))) + +(define (make-sandbox-namespace-specs make-ns . paths) + + (define parent + (delay + (let* ([ns (make-ns)]) + (parameterize ([current-namespace ns]) + (for ([path (in-list paths)]) + (dynamic-require path #f))) + ns))) + + (define (make-child) + (let* ([ns (make-ns)]) + (parameterize ([current-namespace ns]) + (for ([path (in-list paths)]) + (namespace-attach-module (force parent) path))) + ns)) + + (list make-child)) diff --git a/collects/unstable/cce/scribble.ss b/collects/unstable/cce/scribble.ss new file mode 100644 index 0000000000..330c98fc88 --- /dev/null +++ b/collects/unstable/cce/scribble.ss @@ -0,0 +1,72 @@ +#lang scheme/base + +(require scribble/manual "sandbox.ss" "planet.ss" + (for-syntax scheme/base "syntax.ss")) + +(define-for-syntax (make-planet-paths stx ids) + (map (lambda (id) (make-planet-path stx id)) (syntax->list ids))) + +(define-syntax (defmodule/this-package stx) + + (define (make-defmodule opt-name locals others) + (quasisyntax/loc stx + (defmodule + #,(make-planet-path stx opt-name) + #:use-sources + [#,@(make-planet-paths stx locals) #,@others]))) + + (syntax-case stx () + [(_) (make-defmodule #f #'() #'())] + [(_ name) (make-defmodule #'name #'() #'())] + [(_ #:use-sources [local ...] [other ...]) + (make-defmodule #f #'(local ...) #'(other ...))] + [(_ name #:use-sources [local ...] [other ...]) + (make-defmodule #'name #'(local ...) #'(other ...))])) + +(define-syntax (defmodule*/no-declare/this-package stx) + + (define (make-defmodule*/no-declare local-mods other-mods) + (quasisyntax/loc stx + (defmodule*/no-declare + [#,@(make-planet-paths stx local-mods) #,@other-mods]))) + + (syntax-case stx () + [(_ [local-mod ...] [other-mod ...]) + (make-defmodule*/no-declare #'(local-mod ...) #'(other-mod ...))])) + +(define-syntax (declare-exporting/this-package stx) + + (define (make-declare-exporting local-mods other-mods local-srcs other-srcs) + (quasisyntax/loc stx + (declare-exporting + #,@(make-planet-paths stx local-mods) #,@other-mods + #:use-sources + [#,@(make-planet-paths stx local-srcs) #,@other-srcs]))) + + (syntax-case stx () + [(_ [local-mod ...] [other-mod ...]) + (make-declare-exporting #'(local-mod ...) #'(other-mod ...) #'() #'())] + [(_ [local-mod ...] [other-mod ...] + #:use-sources + [local-src ...] [other-src ...]) + (make-declare-exporting #'(local-mod ...) #'(other-mod ...) + #'(local-src ...) #'(other-src ...))])) + +(define-syntax (schememodname/this-package stx) + + (define (make-schememodname id/f) + (quasisyntax/loc stx + (schememodname #,(make-planet-path stx id/f)))) + + (syntax-case stx () + [(_) (make-schememodname #f)] + [(_ path) (make-schememodname #'path)])) + +(provide defmodule/this-package + defmodule*/no-declare/this-package + schememodname/this-package + declare-exporting/this-package + this-package-version-symbol + this-package-in + make-scribble-evaluator + make-scribble-module-evaluator) diff --git a/collects/unstable/cce/set.ss b/collects/unstable/cce/set.ss new file mode 100644 index 0000000000..85947b4adf --- /dev/null +++ b/collects/unstable/cce/set.ss @@ -0,0 +1,292 @@ +#lang scheme + +(require "dict.ss") + +;; A Set is either a Dict or a struct with the prop:set property. +;; A SetProperty is: +;; (Vector (-> Set Any Any) +;; (Or (-> Set Any Void) #f) +;; (Or (-> Set Any Set) #f) +;; (Or (-> Set Any Void) #f) +;; (Or (-> Set Any Set) #f) +;; (-> Set ExactInteger) +;; (-> Set Sequence)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Set Property +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; set-property-guard : Any (List ...) -> Any +;; Protects prop:set from bad inputs. +(define (set-property-guard prop info) + (check-vector 'prop:set "property" prop 7) + (check-vector-element 'prop:set "property" prop 0 + check-procedure "contains?" 2) + (check-vector-element 'prop:set "property" prop 1 + check-optional "insert!" check-procedure 2) + (check-vector-element 'prop:set "property" prop 2 + check-optional "insert" check-procedure 2) + (check-vector-element 'prop:set "property" prop 3 + check-optional "remove!" check-procedure 2) + (check-vector-element 'prop:set "property" prop 4 + check-optional "remove" check-procedure 2) + (check-vector-element 'prop:set "property" prop 5 + check-procedure "count" 1) + (check-vector-element 'prop:set "property" prop 6 + check-procedure "to-sequence" 1) + prop) + +(define-values [ prop:set set-struct? get ] + (make-struct-type-property 'set set-property-guard)) + +(define (prop-contains? prop) (vector-ref prop 0)) +(define (prop-insert! prop) (vector-ref prop 1)) +(define (prop-insert prop) (vector-ref prop 2)) +(define (prop-remove! prop) (vector-ref prop 3)) +(define (prop-remove prop) (vector-ref prop 4)) +(define (prop-count prop) (vector-ref prop 5)) +(define (prop-to-sequence prop) (vector-ref prop 6)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Core Functions +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (set? set) + (or (set-struct? set) + (dict? set))) + +(define (set-can-insert? set) + (if (set-struct? set) + (procedure? (prop-insert (get set))) + (dict-can-functional-set? set))) + +(define (set-can-remove? set) + (if (set-struct? set) + (procedure? (prop-remove (get set))) + (and (dict-can-functional-set? set) + (dict-can-remove-keys? set)))) + +(define (set-can-insert!? set) + (if (set-struct? set) + (procedure? (prop-insert! (get set))) + (dict-mutable? set))) + +(define (set-can-remove!? set) + (if (set-struct? set) + (procedure? (prop-remove! (get set))) + (and (dict-mutable? set) + (dict-can-remove-keys? set)))) + +(define (set-contains? set x) + (if (set-struct? set) + ((prop-contains? (get set)) set x) + (dict-has-key? set x))) + +(define (set-insert! set x) + (if (set-struct? set) + ((prop-insert! (get set)) set x) + (dict-set! set x null))) + +(define (set-insert set x) + (if (set-struct? set) + ((prop-insert (get set)) set x) + (dict-set set x null))) + +(define (set-remove! set x) + (if (set-struct? set) + ((prop-remove! (get set)) set x) + (dict-remove! set x))) + +(define (set-remove set x) + (if (set-struct? set) + ((prop-remove (get set)) set x) + (dict-remove set x))) + +(define (set-count set) + (if (set-struct? set) + ((prop-count (get set)) set) + (dict-count set))) + +(define (in-set set) + (if (set-struct? set) + ((prop-to-sequence (get set)) set) + (in-dict-keys set))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Derived Functions +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (set->list set) + (for/list ([elem (in-set set)]) elem)) + +(define (set-empty? set) + (= (set-count set) 0)) + +(define (set #:weak? [weak? #f] + #:mutable? [mutable? weak?] + #:compare [compare 'equal] + . elements) + (list->set elements #:mutable? mutable? #:weak? weak? #:compare compare)) + +(define (list->set elems + #:weak? [weak? #f] + #:mutable? [mutable? weak?] + #:compare [compare 'equal]) + (make-dict (for/list ([e (in-list elems)]) (cons e null)) + #:mutable? mutable? #:weak? weak? #:compare compare)) + +(define (empty-set #:weak? [weak? #f] + #:mutable? [mutable? weak?] + #:compare [compare 'equal]) + (empty-dict #:mutable? mutable? #:weak? weak? #:compare compare)) + +(define (custom-set #:compare compare + #:hash [hash (lambda (x) 0)] + #:hash2 [hash2 (lambda (x) 0)] + #:weak? [weak? #f] + #:mutable? [mutable? weak?] + . elems) + (let* ([s (custom-dict compare hash hash2 #:mutable? mutable? #:weak? weak?)]) + (if mutable? + (begin0 s + (for ([elem (in-list elems)]) (set-insert! s elem))) + (for/fold ([s s]) ([elem (in-list elems)]) + (set-insert s elem))))) + +(define (set=? one two) + (and (subset? one two) + (subset? two one))) + +(define (proper-subset? one two) + (and (subset? one two) + (not (subset? two one)))) + +(define (subset? one two) + (for/and ([elem (in-set one)]) + (set-contains? two elem))) + +(define (set-union set . rest) + (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set two)]) + (set-insert one elem))) + +(define (set-intersection set . rest) + (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set one)] + #:when (not (set-contains? two elem))) + (set-remove one elem))) + +(define (set-difference set . rest) + (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set one)] + #:when (set-contains? two elem)) + (set-remove one elem))) + +(define (set-exclusive-or set . rest) + (for*/fold ([one set]) ([two (in-list rest)] [elem (in-set two)]) + (if (set-contains? one elem) + (set-remove one elem) + (set-insert one elem)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Generic Checks +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (check-vector caller desc value size) + (unless (vector? value) + (error caller "expected ~a to be a vector; got: ~e" desc value)) + (unless (= (vector-length value) size) + (error caller + "expected ~a to have length ~a; got length ~a in: ~e" + desc size (vector-length value) value))) + +(define (check-vector-element caller desc value index check part . args) + (apply check + caller + (format "~a element ~a (~a)" desc index part) + (vector-ref value index) + args)) + +(define (check-procedure caller desc value arity) + (unless (procedure? value) + (error caller "expected ~a to be a procedure; got: ~e" desc value)) + (unless (procedure-arity-includes? value arity) + (error caller + "expected ~a to accept ~a arguments; got: ~e" + desc + arity + value))) + +(define (check-optional caller desc value check . args) + (when value (apply check caller desc value args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Exports +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide/contract + [set? (-> any/c boolean?)] + [set-empty? (-> any/c boolean?)] + [set + (->* [] + [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)] + #:rest list? + set?)] + [list->set + (->* [list?] + [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)] + set?)] + [empty-set + (->* [] + [#:mutable? boolean? #:weak? boolean? #:compare (or/c 'eq 'eqv 'equal)] + set?)] + [custom-set + (->* [#:compare (-> any/c any/c any/c)] + [#:hash + (-> any/c exact-integer?) + #:hash2 + (-> any/c exact-integer?) + #:mutable? boolean? + #:weak? boolean?] + #:rest list? + set?)] + [set->list (-> set? list?)] + [set-contains? (-> set? any/c boolean?)] + [set-insert (-> set? any/c any/c)] + [set-remove (-> set? any/c set?)] + [set-insert! (-> set? any/c void?)] + [set-remove! (-> set? any/c void?)] + [set-can-insert? (-> set? boolean?)] + [set-can-remove? (-> set? boolean?)] + [set-can-insert!? (-> set? boolean?)] + [set-can-remove!? (-> set? boolean?)] + [set-count (-> set? exact-nonnegative-integer?)] + [in-set (-> set? sequence?)] + [set=? (-> set? set? boolean?)] + [subset? (-> set? set? boolean?)] + [proper-subset? (-> set? set? boolean?)] + [set-union + (->* [(and/c set? set-can-insert?)] [] + #:rest (listof set?) + set?)] + [set-intersection + (->* [(and/c set? set-can-remove?)] [] + #:rest (listof set?) + set?)] + [set-difference + (->* [(and/c set? set-can-remove?)] [] + #:rest (listof set?) + set?)] + [set-exclusive-or + (->* [(and/c set? set-can-insert? set-can-remove?)] [] + #:rest (listof set?) + set?)] + [prop:set struct-type-property?] + ) diff --git a/collects/unstable/cce/slideshow.ss b/collects/unstable/cce/slideshow.ss new file mode 100644 index 0000000000..3523549da5 --- /dev/null +++ b/collects/unstable/cce/slideshow.ss @@ -0,0 +1,307 @@ +#lang scheme + +(require slideshow/base slideshow/pict + scheme/splicing scheme/stxparam scheme/gui/base + "define.ss") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Font Controls +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-with-parameter with-size current-font-size) +(define-syntax-rule (with-scale scale expr) + (with-size (inexact->exact (ceiling (* scale (current-font-size)))) expr)) +(define-syntax-rule (define-scale name scale) + (define-syntax-rule (name expr) (with-scale scale expr))) +(define-scale big 3/2) +(define-scale small 2/3) + +(define-with-parameter with-font current-main-font) +(define-syntax-rule (with-style style expr) + (with-font (cons style (current-main-font)) expr)) +(define-syntax-rule (define-style name style) + (define-syntax-rule (name expr) (with-style style expr))) +(define-style bold 'bold) +(define-style italic 'italic) +(define-style subscript 'subscript) +(define-style superscript 'superscript) +(define-style caps 'caps) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Picture Manipulation +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (fill pict w h) + (cc-superimpose + pict + (blank (or w (pict-width pict)) + (or h (pict-height pict))))) + +(define (color c p) (colorize p c)) + +(define color/c + (or/c string? ;; might be faster + ;;(and/c string? (lambda (s) (send the-color-database find-color s))) + (is-a?/c color%) + (list/c byte? byte? byte?))) + +(define-syntax-rule (define-colors name ...) + (begin (define (name pict) (color (symbol->string 'name) pict)) ...)) + +(define-colors + red orange yellow green blue purple + black brown gray white cyan magenta) + +(define (light c) (scale-color 2 c)) +(define (dark c) (scale-color 1/2 c)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Slide / Paragraph Manipulation +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-with-parameter column current-para-width) + +(define (columns . picts) + (apply hc-append gap-size (map baseless picts))) + +(define (column-size n [r (/ n)]) + (* r (- (current-para-width) (* (sub1 n) gap-size)))) + +(define-syntax-rule (two-columns a b) + (columns (column (column-size 2) a) + (column (column-size 2) b))) + +(define (mini-slide . picts) + (apply vc-append gap-size picts)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Simple Tables +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define =! + (case-lambda + [(n) n] + [(n . ns) + (if (apply = n ns) + n + (error '=! "not all equal: ~a" (cons n ns)))])) + +(define (elem->pict elem) + (if (string? elem) (t elem) elem)) + +(define (tabular #:gap [gap gap-size] + #:vgap [vgap gap] + #:hgap [hgap gap] + #:align [align lbl-superimpose] + #:halign [halign align] + #:valign [valign align] + . cells) + (let* ([rows (length cells)] + [cols (apply =! (map length cells))] + [picts (map elem->pict (append* cells))] + [haligns (for/list ([i (in-range 0 cols)]) halign)] + [valigns (for/list ([i (in-range 0 rows)]) valign)] + [hseps (for/list ([i (in-range 1 cols)]) hgap)] + [vseps (for/list ([i (in-range 1 rows)]) vgap)]) + (table cols picts haligns valigns hseps vseps))) + +(define (matrixof c) + (and/c (listof (listof c)) + (flat-named-contract "matrix" + (match-lambda + [(list) #t] + [(list _) #t] + [(list xs ...) (apply = (map length xs))])))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Space-smart picture selection +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax-parameter pict-combine #'ltl-superimpose) + +(define-syntax-rule (with-pict-combine combine body ...) + (splicing-syntax-parameterize + ([pict-combine #'combine]) + body ...)) + +(define-syntax (pict-if stx) + (syntax-case stx () + [(_ #:combine combine test success failure) + (syntax/loc stx + (let* ([result test]) + (combine (show success result) + (hide failure result))))] + [(_ test success failure) + (quasisyntax/loc stx + (pict-if #:combine #,(syntax-parameter-value #'pict-combine) + test success failure))])) + +(define-syntax (pict-cond stx) + (syntax-case stx (else) + [(_ #:combine combine [test expr] ... [else default]) + (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))]) + (syntax/loc stx + (let ([pict expr] ... [final default]) + (combine (cond [test pict] ... [else final]) + (ghost pict) ... (ghost final)))))] + [(_ #:combine combine [test pict] ...) + (syntax/loc stx + (pict-cond #:combine combine [test pict] ... [else (blank 0 0)]))] + [(_ [test expr] ...) + (quasisyntax/loc stx + (pict-cond #:combine #,(syntax-parameter-value #'pict-combine) + [test expr] ...))])) + +(define-syntax (pict-case stx) + (syntax-case stx (else) + [(_ test #:combine combine [literals expr] ... [else default]) + (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))]) + (syntax/loc stx + (let ([pict expr] ... [final default]) + (combine (case test [literals pict] ... [else final]) + (ghost pict) ... (ghost final)))))] + [(_ test #:combine combine [literals expr] ...) + (syntax/loc stx + (pict-case #:combine combine [literals expr] ... [else (blank 0 0)]))] + [(_ test [literals expr] ...) + (quasisyntax/loc stx + (pict-case test #:combine #,(syntax-parameter-value #'pict-combine) + [literals expr] ...))])) + +(define-syntax (pict-match stx) + (syntax-case stx () + [(_ test #:combine combine [pattern expr] ...) + (with-syntax ([(pict ...) (generate-temporaries #'(expr ...))]) + (syntax/loc stx + (let ([pict expr] ...) + (combine (match test [pattern pict] ... [_ (blank 0 0)]) + (ghost pict) ...))))] + [(_ test [pattern expr] ...) + (quasisyntax/loc stx + (pict-match test #:combine #,(syntax-parameter-value #'pict-combine) + [pattern expr] ...))])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Slide Staging +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-for-syntax (stage-keyword stx) + (raise-syntax-error #f "not in the body of a staged slide" stx)) + +(define-syntax-parameter stage stage-keyword) +(define-syntax-parameter stage-name stage-keyword) + +(define-syntax (staged stx) + (syntax-case stx () + [(_ [name ...] body ...) + (let* ([ids (syntax->list #'(name ...))]) + + (for ([id (in-list ids)] #:when (not (identifier? id))) + (raise-syntax-error #f "expected an identifier" stx id)) + + (with-syntax ([(num ...) + (for/list ([i (in-naturals 1)] [id (in-list ids)]) + (datum->syntax #'here i id))]) + + (syntax/loc stx + (let* ([name num] ...) + (define (staged-computation number symbol) + (syntax-parameterize + ([stage (make-rename-transformer #'number)] + [stage-name (make-rename-transformer #'symbol)]) + (block body ...))) + (begin (staged-computation name 'name) ...)))))])) + +(define-syntax-rule (slide/stage [name ...] body ...) + (staged [name ...] (slide body ...))) + +(define-syntax-rule (before name) (< stage name)) +(define-syntax-rule (before/at name) (<= stage name)) +(define-syntax-rule (at/after name) (>= stage name)) +(define-syntax-rule (after name) (> stage name)) +(define-syntax-rule (before/after name) (not (= stage name))) +(define-syntax-rule (at name ...) (or (= stage name) ...)) + +(define (hide pict [hide? #t]) + (if hide? (ghost pict) pict)) + +(define (show pict [show? #t]) + (if show? pict (ghost pict))) + +(define (shade pict [shade? #t] #:ratio [ratio 0.5]) + (if shade? (cellophane pict ratio) pict)) + +(define (strike pict [strike? #t]) + (if strike? + (pin-over pict + 0 + (/ (pict-height pict) 2) + (pip-line (pict-width pict) 0 0)) + pict)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Exports +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide with-size with-scale big small + with-font with-style bold italic subscript superscript caps) + +(provide/contract + [color/c flat-contract?] + [red (-> pict? pict?)] + [orange (-> pict? pict?)] + [yellow (-> pict? pict?)] + [green (-> pict? pict?)] + [blue (-> pict? pict?)] + [purple (-> pict? pict?)] + [black (-> pict? pict?)] + [brown (-> pict? pict?)] + [gray (-> pict? pict?)] + [white (-> pict? pict?)] + [cyan (-> pict? pict?)] + [magenta (-> pict? pict?)] + [light (-> color/c color/c)] + [dark (-> color/c color/c)] + [color (-> color/c pict? pict?)] + [fill + (-> pict? + (or/c (real-in 0 +inf.0) #f) + (or/c (real-in 0 +inf.0) #f) + pict?)]) + +(provide column columns column-size two-columns mini-slide) + +(provide/contract + [tabular (->* [] + [#:gap natural-number/c + #:hgap natural-number/c + #:vgap natural-number/c + #:align (->* [] [] #:rest (listof pict?) pict?) + #:halign (->* [] [] #:rest (listof pict?) pict?) + #:valign (->* [] [] #:rest (listof pict?) pict?)] + #:rest (matrixof (or/c string? pict?)) + pict?)]) + +(provide/contract + [hide (->* [pict?] [any/c] pict?)] + [show (->* [pict?] [any/c] pict?)] + [strike (->* [pict?] [any/c] pict?)] + [shade (->* [pict?] [any/c #:ratio (real-in 0 1)] pict?)]) +(provide staged slide/stage stage stage-name + before at after before/at at/after except + pict-if pict-cond pict-case pict-match + pict-combine with-pict-combine) diff --git a/collects/unstable/cce/syntax.ss b/collects/unstable/cce/syntax.ss new file mode 100644 index 0000000000..68bfeb9812 --- /dev/null +++ b/collects/unstable/cce/syntax.ss @@ -0,0 +1,278 @@ +#lang scheme/base +(require scheme/path + scheme/match + scheme/contract + scheme/vector + scheme/list + syntax/stx + syntax/kerncase + setup/main-collects + planet/planet-archives + (for-template scheme/base) + (for-syntax scheme/base) + (for-label scheme) + "private/syntax-core.ss" + "private/define-core.ss" + (for-template "private/define-core.ss") + "contract.ss" + "text.ss") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; SYNTAX OBJECTS +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Syntax Locations +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (syntax-source-directory stx) + (match (syntax-source stx) + [(? path-string? source) + (let-values ([(base file dir?) (split-path source)]) + (and (path? base) + (path->complete-path base + (or (current-load-relative-directory) + (current-directory)))))] + [_ #f])) + +(define (syntax-source-file-name stx) + (match (syntax-source stx) + [(? path-string? f) + (let-values ([(base file dir?) (split-path f)]) file)] + [_ #f])) + +(define (syntax-source-planet-package stx) + (let* ([dir (syntax-source-directory stx)]) + (and dir (this-package-version/proc dir)))) + +(define (syntax-source-planet-package-owner stx) + (let* ([pkg (syntax-source-planet-package stx)]) + (and pkg (pd->owner pkg)))) + +(define (syntax-source-planet-package-name stx) + (let* ([pkg (syntax-source-planet-package stx)]) + (and pkg (pd->name pkg)))) + +(define (syntax-source-planet-package-major stx) + (let* ([pkg (syntax-source-planet-package stx)]) + (and pkg (pd->maj pkg)))) + +(define (syntax-source-planet-package-minor stx) + (let* ([pkg (syntax-source-planet-package stx)]) + (and pkg (pd->min pkg)))) + +(define (syntax-source-planet-package-symbol stx [suffix #f]) + (match (syntax-source-planet-package stx) + [(list owner name major minor) + (string->symbol + (format "~a/~a:~a:~a~a" + owner + (regexp-replace "\\.plt$" name "") + major + minor + (if suffix (text->string "/" suffix) "")))] + [#f #f])) + +(define (make-planet-path stx id/f) + (datum->syntax + stx + (list #'planet (syntax-source-planet-package-symbol stx id/f)) + (or id/f stx))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Transformer patterns: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define ((redirect-transformer id) stx) + (cond + [(identifier? stx) id] + [(and (stx-pair? stx) (identifier? (stx-car stx))) + (to-syntax (cons id (stx-cdr stx)) #:stx stx)] + [else + (syntax-error + stx + "expected an identifier (alone or in application position); cannot redirect to ~a" + (syntax-e id))])) + +(define (head-expand stx [stop-ids null]) + (local-expand stx + (syntax-local-context) + (append stop-ids (full-kernel-form-identifier-list)) + #f)) + +(define-syntax-if-unbound quote-syntax/prune + (make-rename-transformer #'quote-syntax)) + +(define (full-kernel-form-identifier-list) + (remove-duplicates + (list* (quote-syntax/prune #%require) + (quote-syntax/prune #%provide) + (quote-syntax/prune module) + (quote-syntax/prune #%plain-module-begin) + (kernel-form-identifier-list)) + free-identifier=?)) + +(define (quote-transformer datum) + #`(quasiquote + #,(let loop ([datum datum]) + (cond + [(syntax? datum) #`(unquote (quote-syntax #,datum))] + [(pair? datum) #`#,(cons (loop (car datum)) (loop (cdr datum)))] + [(vector? datum) #`#,(vector-map loop datum)] + [(box? datum) #`#,(box (loop (unbox datum)))] + [(hash? datum) + #`#,((cond [(hash-eqv? datum) make-immutable-hasheqv] + [(hash-eq? datum) make-immutable-hasheq] + [else make-immutable-hash]) + (hash-map datum (lambda (k v) (cons k (loop v)))))] + [(prefab-struct-key datum) => + (lambda (key) + #`#,(apply make-prefab-struct + key + (for/list ([i (in-vector (struct->vector datum) 1)]) + (loop i))))] + [else #`#,datum])))) + +(define trampoline-prompt-tag + (make-continuation-prompt-tag 'trampoline)) + +(define ((trampoline-transformer transform) stx) + + (define intro (make-syntax-introducer)) + + (define (body) + (syntax-local-introduce + (intro + (transform (trampoline-evaluator intro) + intro + (intro (syntax-local-introduce stx)))))) + + (call-with-continuation-prompt body trampoline-prompt-tag)) + +(define ((trampoline-evaluator intro) stx) + + (define ((wrap continue)) + (call-with-continuation-prompt continue trampoline-prompt-tag)) + + (define ((expander continue)) + #`(begin #,(syntax-local-introduce (intro stx)) + (#%trampoline #,(wrap continue)))) + + (define (body continue) + (abort-current-continuation trampoline-prompt-tag (expander continue))) + + (call-with-composable-continuation body trampoline-prompt-tag) + (void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; From planet/util: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (this-package-version/proc srcdir) + (let* ([package-roots (get-all-planet-packages)] + [thepkg (ormap (predicate->projection (contains-dir? srcdir)) + package-roots)]) + (and thepkg (archive-retval->simple-retval thepkg)))) + +;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X) +(define (predicate->projection pred) (lambda (x) (if (pred x) x #f))) + +;; contains-dir? : path -> pkg -> boolean +(define ((contains-dir? srcdir) alleged-superdir-pkg) + (let* ([nsrcdir (normalize-path srcdir)] + [nsuperdir (normalize-path (car alleged-superdir-pkg))] + [nsrclist (explode-path nsrcdir)] + [nsuperlist (explode-path nsuperdir)]) + (list-prefix? nsuperlist nsrclist))) + +(define (list-prefix? sup sub) + (let loop ([sub sub] + [sup sup]) + (cond + [(null? sup) #t] + [(equal? (car sup) (car sub)) + (loop (cdr sub) (cdr sup))] + [else #f]))) + +(define (archive-retval->simple-retval p) + (list-refs p '(1 2 4 5))) + +(define-values (pd->owner pd->name pd->maj pd->min) + (apply values (map (lambda (n) (lambda (l) (list-ref l n))) '(0 1 2 3)))) + +(define (list-refs p ns) + (map (lambda (n) (list-ref p n)) ns)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; EXPORTS +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define stx/f (or/c syntax? #f)) + +(define nat/f (or/c nat/c #f)) +(define pos/f (or/c pos/c #f)) + +(define src-list/c (list/c any/c pos/f nat/f pos/f nat/f)) +(define src-vector/c (vector/c any/c pos/f nat/f pos/f nat/f)) + +(define src/c + (or/c srcloc? + syntax? + src-list/c + src-vector/c + #f)) + +(provide/contract + + [src/c flat-contract?] + [src-known? (-> src/c boolean?)] + [src->srcloc (->* [] [] #:rest (listof src/c) srcloc?)] + [src->list (->* [] [] #:rest (listof src/c) src-list/c)] + [src->vector (->* [] [] #:rest (listof src/c) src-vector/c)] + [src->syntax (->* [] [] #:rest (listof src/c) syntax?)] + + [syntax-datum/c (-> flat-contract? flat-contract?)] + [syntax-listof/c (-> flat-contract? flat-contract?)] + [syntax-list/c + (->* [] [] #:rest (listof flat-contract?) flat-contract?)] + + [syntax-map (-> (-> syntax? any/c) (syntax-listof/c any/c) (listof any/c))] + [to-syntax + (->* [any/c] + [#:stx stx/f #:src src/c #:ctxt stx/f #:prop stx/f #:cert stx/f] + syntax?)] + [to-datum (-> any/c (not/c syntax?))] + + [syntax-source-file-name (-> syntax? (or/c path? #f))] + [syntax-source-directory (-> syntax? (or/c path? #f))] + [syntax-source-planet-package + (-> syntax? (or/c (list/c string? string? nat/c nat/c) #f))] + [syntax-source-planet-package-owner (-> syntax? (or/c string? #f))] + [syntax-source-planet-package-name (-> syntax? (or/c string? #f))] + [syntax-source-planet-package-major (-> syntax? (or/c nat/c #f))] + [syntax-source-planet-package-minor (-> syntax? (or/c nat/c #f))] + [syntax-source-planet-package-symbol + (->* [syntax?] [(or/c text? #f)] (or/c symbol? #f))] + [make-planet-path (-> syntax? (or/c identifier? #f) syntax?)] + + [trampoline-transformer + (-> (-> (-> syntax? void?) (-> syntax? syntax?) syntax? syntax?) + (-> syntax? syntax?))] + [quote-transformer (-> any/c syntax?)] + [redirect-transformer (-> identifier? (-> syntax? syntax?))] + [head-expand (->* [syntax?] [(listof identifier?)] syntax?)] + [full-kernel-form-identifier-list (-> (listof identifier?))] + + [current-syntax (parameter/c (or/c syntax? false/c))] + [syntax-error (->* [syntax? string?] + [#:name (or/c text? #f)] + #:rest list? + none/c)]) + +(provide with-syntax* syntax-list) diff --git a/collects/unstable/cce/test/checks.ss b/collects/unstable/cce/test/checks.ss new file mode 100644 index 0000000000..89d9ceb9e3 --- /dev/null +++ b/collects/unstable/cce/test/checks.ss @@ -0,0 +1,79 @@ +#lang scheme + +(require scheme/pretty + srfi/67 + "../require-provide.ss") + +(require/provide schemeunit schemeunit/text-ui) + +(provide (all-defined-out)) + +(define-syntax test + (syntax-rules () + [(_ term) (test-case (pretty-format 'term) term)] + [(_ term ...) (test-case (pretty-format '(begin term ...)) term ...)])) + +(define-syntax-rule (test-ok body ...) + (test (check-ok body ...))) + +(define-syntax-rule (test-bad body ...) + (test (check-bad body ...))) + +(define-syntax-rule (with/c c e) + (let () (with-contract value ([value c]) (define value e)) value)) + +(define-syntax-rule (check-ok body ...) + (check-not-exn (lambda () body ...))) + +(define-syntax-rule (check-bad body ...) + (check-exn exn:fail:contract? (lambda () body ...))) + +(define-check (check-not compare actual expected) + (with-check-info* + (list (make-check-info 'comparison compare) + (make-check-actual actual) + (make-check-expected expected)) + (lambda () + (let* ([result (compare actual expected)]) + (when result + (with-check-info* + (list (make-check-info 'result result)) + (lambda () (fail-check)))))))) + +(define (check/sort actual expected + #:< [<< ( (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-contract.ss b/collects/unstable/cce/test/test-contract.ss new file mode 100644 index 0000000000..1929381c71 --- /dev/null +++ b/collects/unstable/cce/test/test-contract.ss @@ -0,0 +1,83 @@ +#lang scheme + +(require "checks.ss" + "../contract.ss") + +(provide contract-suite) + +(define contract-suite + (test-suite "contract.ss" + (test-suite "Flat Contracts" + (test-suite "nat/c" + (test-ok (with/c nat/c 1)) + (test-ok (with/c nat/c 0)) + (test-bad (with/c nat/c -1)) + (test-bad (with/c nat/c 'non-numeric))) + (test-suite "pos/c" + (test-ok (with/c pos/c 1)) + (test-bad (with/c pos/c 0)) + (test-bad (with/c pos/c -1)) + (test-bad (with/c pos/c 'non-numeric))) + (test-suite "truth/c" + (test-ok (with/c truth/c #t)) + (test-ok (with/c truth/c #f)) + (test-ok (with/c truth/c '(x))))) + (test-suite "Higher Order Contracts" + (test-suite "thunk/c" + (test-ok ([with/c thunk/c gensym])) + (test-bad ([with/c thunk/c gensym] 'x)) + (test-bad ([with/c thunk/c cons]))) + (test-suite "unary/c" + (test-ok ([with/c unary/c list] 'x)) + (test-bad ([with/c unary/c list] 'x 'y)) + (test-bad ([with/c unary/c cons] 1))) + (test-suite "binary/c" + (test-ok ([with/c binary/c +] 1 2)) + (test-bad ([with/c binary/c +] 1 2 3)) + (test-bad ([with/c binary/c symbol->string] 'x 'y))) + (test-suite "predicate/c" + (test-ok ([with/c predicate/c integer?] 1)) + (test-ok ([with/c predicate/c integer?] 1/2)) + (test-bad ([with/c predicate/c values] 'x))) + (test-suite "predicate-like/c" + (test-ok ([with/c predicate-like/c integer?] 1)) + (test-ok ([with/c predicate-like/c integer?] 1/2)) + (test-ok ([with/c predicate-like/c values] 'x))) + (test-suite "comparison/c" + (test-ok ([with/c comparison/c equal?] 1 1)) + (test-ok ([with/c comparison/c equal?] 1 2)) + (test-bad ([with/c comparison/c list] 1 2))) + (test-suite "comparison-like/c" + (test-ok ([with/c comparison-like/c equal?] 1 1)) + (test-ok ([with/c comparison-like/c equal?] 1 2)) + (test-ok ([with/c comparison-like/c list] 1 2)))) + (test-suite "Collection Contracts" + (test-suite "sequence/c" + (test-ok + (for ([x (with/c (sequence/c integer?) (list 1 2 3 4))]) + (void))) + (test-bad + (for ([x (with/c (sequence/c integer?) (list 1 2 'c 4))]) + (void))) + (test-bad + (for ([x (with/c (sequence/c integer? symbol?) (list 1 2 3 4))]) + (void)))) + (test-suite "dict/c" + (test-ok + (for ([(x y) + (in-dict + (with/c (dict/c integer? symbol?) + #hash([1 . a] [2 . b])))]) + (void))) + (test-bad + (for ([(x y) + (in-dict + (with/c (dict/c integer? symbol?) + #hash([1 . a] [three . b])))]) + (void))) + (test-bad + (for ([(x y) + (in-dict + (with/c (dict/c integer? symbol?) + #hash([1 . a] [2 . "b"])))]) + (void))))))) diff --git a/collects/unstable/cce/test/test-debug.ss b/collects/unstable/cce/test/test-debug.ss new file mode 100644 index 0000000000..6caf26a048 --- /dev/null +++ b/collects/unstable/cce/test/test-debug.ss @@ -0,0 +1,24 @@ +#lang scheme + +(require "checks.ss" + "../debug.ss") + +(provide debug-suite) + +(define debug-suite + (test-suite "debug.ss" + (test-suite "dprintf" + (test + (let () + (define logger (make-logger)) + (define receiver (make-log-receiver logger 'debug)) + (parameterize ([current-logger logger]) + (dprintf "Danger, ~a!" "Will Robinson")) + (check-not-false + (member + "Danger, Will Robinson!" + (let loop () + (match (sync/timeout 0 receiver) + [(vector 'debug (? string? message) _) + (cons message (loop))] + [_ null]))))))))) diff --git a/collects/unstable/cce/test/test-define.ss b/collects/unstable/cce/test/test-define.ss new file mode 100644 index 0000000000..0711529094 --- /dev/null +++ b/collects/unstable/cce/test/test-define.ss @@ -0,0 +1,99 @@ +#lang scheme + +(require scheme/sandbox + "checks.ss" + "../define.ss") + +(provide define-suite) + +(define define-suite + (test-suite "define.ss" + + (test-suite "block" + (test + (block + (define (f x y) (both x y)) + (define-match-expander both + (syntax-rules () [(_ a b) (struct pair [a b])]) + (syntax-rules () [(_ a b) (make-pair a b)])) + (define-struct pair [x y] #:transparent) + (check-equal? (f 1 2) (make-pair 1 2))))) + + (test-suite "at-end") + + (test-suite "define-if-unbound" + (test + (let () + (define-if-unbound very-special-name 1) + (define-if-unbound very-special-name 2) + (check-equal? very-special-name 1))) + (test + (let () + (define-if-unbound (very-special-function) 1) + (define-if-unbound (very-special-function) 2) + (check-equal? (very-special-function) 1)))) + + (test-suite "define-values-if-unbound" + (test + (let () + (define-values-if-unbound [very-special-name] 1) + (define-values-if-unbound [very-special-name] 2) + (check-equal? very-special-name 1)))) + + (test-suite "define-syntax-if-unbound" + (test + (let () + (define-syntax-if-unbound very-special-macro + (lambda (stx) #'(quote 1))) + (define-syntax-if-unbound very-special-macro + (lambda (stx) #'(quote 2))) + (check-equal? (very-special-macro) 1))) + (test + (let () + (define-syntax-if-unbound (very-special-macro stx) + #'(quote 1)) + (define-syntax-if-unbound (very-special-macro stx) + #'(quote 2)) + (check-equal? (very-special-macro) 1)))) + + (test-suite "define-syntaxes-if-unbound" + (test + (let () + (define-syntaxes-if-unbound [very-special-macro] + (lambda (stx) #'(quote 1))) + (define-syntaxes-if-unbound [very-special-macro] + (lambda (stx) #'(quote 2))) + (check-equal? (very-special-macro) 1)))) + + (test-suite "define-renamings" + (test + (let () + (define-renamings [with define] [fun lambda]) + (with f (fun (x) (add1 x))) + (check-equal? (f 7) 8)))) + + (test-suite "declare-names" + (test + (let () + (declare-names x y z) + (define-values [x y z] (values 1 2 3)) + (check-equal? x 1) + (check-equal? y 2) + (check-equal? z 3)))) + + (test-suite "define-with-parameter" + (test + (let () + (define p (make-parameter 0)) + (define-with-parameter with-p p) + (with-p 7 (check-equal? (p) 7))))) + + (test-suite "define-single-definition" + (test + (let () + (define-single-definition with define-values) + (with x 0) + (check-equal? x 0)))) + + (test-suite "in-phase1") + (test-suite "in-phase1/pass2"))) diff --git a/collects/unstable/cce/test/test-dict.ss b/collects/unstable/cce/test/test-dict.ss new file mode 100644 index 0000000000..f802e40f86 --- /dev/null +++ b/collects/unstable/cce/test/test-dict.ss @@ -0,0 +1,110 @@ +#lang scheme + +(require "checks.ss" + "../dict.ss") + +(provide dict-suite) + +(define (dict=? a b) + (and (subdict? a b) + (subdict? b a))) + +(define (subdict? a b) + (for/and ([(k v) (in-dict a)]) + (and (dict-has-key? b k) + (equal? (dict-ref b k) v)))) + +(define (check/dict a b) (check dict=? a b)) + +(define dict-suite + (test-suite "dict.ss" + (test-suite "Constructors" + (test-suite "empty-dict" + (test (check/dict (empty-dict) '())) + (test (check/dict (empty-dict #:mutable? #t) '())) + (test (check/dict (empty-dict #:weak? #t) '())) + (test (check/dict (empty-dict #:compare 'eqv) '()))) + (test-suite "make-dict" + (test (check/dict (make-dict '([1 . a] [2 . b])) '([1 . a] [2 . b]))) + (test (check/dict (make-dict '([1 . a] [2 . b]) #:mutable? #t) + '([1 . a] [2 . b]))) + (test (check/dict (make-dict '([1 . a] [2 . b]) #:weak? #t) + '([1 . a] [2 . b]))) + (test (check/dict (make-dict '([1 . a] [2 . b]) #:compare 'eqv) + '([1 . a] [2 . b])))) + (test-suite "custom-dict" + (test (let* ([table (custom-dict = add1 sub1 #:mutable? #t)]) + (dict-set! table 1 'a) + (dict-set! table 2 'b) + (check/dict table '([1 . a] [2 . b])))))) + (test-suite "Lookup" + (test-suite "dict-ref!" + (test-ok (define d (make-hash)) + (check-equal? (dict-ref! d 1 'one) 'one) + (check-equal? (dict-ref! d 1 'uno) 'one) + (check-equal? (dict-ref! d 2 (lambda () 'two)) 'two) + (check-equal? (dict-ref! d 2 (lambda () 'dos)) 'two)) + (test-bad (dict-ref! '([1 . one] [2 . two]) 1 'uno))) + (test-suite "dict-ref/check" + (test-ok (check-equal? (dict-ref/check '([1 . one] [2 . two]) 1) 'one)) + (test-bad (dict-ref/check '([1 . one] [2 . two]) 3))) + (test-suite "dict-ref/identity" + (test-ok (check-equal? (dict-ref/identity '([1 . one] [2 . two]) 1) + 'one)) + (test-ok (check-equal? (dict-ref/identity '([1 . one] [2 . two]) 3) 3))) + (test-suite "dict-ref/default" + (test-ok (check-equal? (dict-ref/default '([1 . one] [2 . two]) 1 '?) + 'one)) + (test-ok (check-equal? (dict-ref/default '([1 . one] [2 . two]) 3 '?) + '?))) + (test-suite "dict-ref/failure" + (test-ok (define x 7) + (define (f) (set! x (+ x 1)) x) + (check-equal? (dict-ref/failure '([1 . one] [2 . two]) 1 f) + 'one) + (check-equal? x 7) + (check-equal? (dict-ref/failure '([1 . one] [2 . two]) 3 f) 8) + (check-equal? x 8)))) + (test-suite "Accessors" + (test-suite "dict-empty?" + (test (check-true (dict-empty? '()))) + (test (check-false (dict-empty? '([1 . a] [2 . b]))))) + (test-suite "dict-has-key?" + (test-ok (check-equal? (dict-has-key? '([1 . one] [2 . two]) 1) #t)) + (test-ok (check-equal? (dict-has-key? '([1 . one] [2 . two]) 3) #f))) + (test-suite "dict-domain" + (test-ok (check-equal? (dict-domain '([1 . one] [2 . two])) '(1 2)))) + (test-suite "dict-range" + (test-ok (check-equal? (dict-range '([1 . one] [2 . two])) + '(one two))))) + (test-suite "Combination" + (test-suite "dict-union" + (test-ok (dict-union '([1 . one] [2 . two]) '([3 . three] [4 . four])) + '([4 . four] [3 . three] [1 . one] [2 . two]))) + (test-suite "dict-union!" + (test-ok (define d (make-hash)) + (dict-union! d '([1 . one] [2 . two])) + (dict-union! d '([3 . three] [4 . four])) + (check-equal? + (hash-copy #hash([1 . one] [2 . two] [3 . three] [4 . four])) + d)))) + (test-suite "Property" + (test-suite "wrapped-dict-property" + (test + (let () + (define (unwrap-table d) (table-dict d)) + (define (wrap-table d) (make-table d)) + (define (wrapped? d) (table? d)) + (define-struct table [dict] + #:transparent + #:property prop:dict + (wrapped-dict-property + #:unwrap unwrap-table + #:wrap wrap-table + #:predicate wrapped?)) + (check-true (dict? (make-table '([1 . a] [2 . b])))) + (check/dict (make-table '([1 . a] [2 . b])) '([1 . a] [2 . b])) + (check-equal? (dict-ref (make-table '([1 . a] [2 . b])) 1) 'a) + (let* ([s (dict-set (make-table '([1 . a] [2 . b])) 3 'c)]) + (check-true (table? s)) + (check/dict s '([1 . a] [2 . b] [3 . c]))))))))) diff --git a/collects/unstable/cce/test/test-exn.ss b/collects/unstable/cce/test/test-exn.ss new file mode 100644 index 0000000000..40d2f473a8 --- /dev/null +++ b/collects/unstable/cce/test/test-exn.ss @@ -0,0 +1,15 @@ +#lang scheme + +(require "checks.ss" + "../exn.ss") + +(provide exn-suite) + +(define exn-suite + (test-suite "exn.ss" + (test-suite "try" + (test-ok (try (+ 1 2))) + (test-bad (try (+ 'a 'b))) + (test-ok (try (+ 'a 'b) (+ 3 4))) + (test-ok (try (+ 1 2) (+ 'a 'b))) + (test-bad (try (+ 'a 'b) (+ 'c 'd)))))) diff --git a/collects/unstable/cce/test/test-function.ss b/collects/unstable/cce/test/test-function.ss new file mode 100644 index 0000000000..6dfd5bca8f --- /dev/null +++ b/collects/unstable/cce/test/test-function.ss @@ -0,0 +1,157 @@ +#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)))))))) + diff --git a/collects/unstable/cce/test/test-hash.ss b/collects/unstable/cce/test/test-hash.ss new file mode 100644 index 0000000000..dedb240c8c --- /dev/null +++ b/collects/unstable/cce/test/test-hash.ss @@ -0,0 +1,74 @@ +#lang scheme + +(require "checks.ss" + "../hash.ss") + +(provide hash-suite) + +(define hash-suite + (test-suite "hash.ss" + (test-suite "hash" + (test (check-equal? (hash [1 'a] [2 'b]) + #hash([1 . a] [2 . b]))) + (test (check-equal? (hash #:eq [1 'a] [2 'b]) + #hasheq([1 . a] [2 . b]))) + (test (check-equal? (hash #:eqv [1 'a] [2 'b]) + #hasheqv([1 . a] [2 . b]))) + (test (check-equal? (hash #:equal [1 'a] [2 'b]) + #hash([1 . a] [2 . b])))) + (test-suite "hash!" + (test (check-equal? (hash! [1 'a] [2 'b]) + (hash-copy #hash([1 . a] [2 . b])))) + (test (check-equal? (hash! #:eq [1 'a] [2 'b]) + (hash-copy #hasheq([1 . a] [2 . b])))) + (test (check-equal? (hash! #:eqv #:weak [1 'a] [2 'b]) + (make-weak-hasheqv '([1 . a] [2 . b])))) + (test (check-equal? (hash! #:weak #:equal [1 'a] [2 'b]) + (make-weak-hash '([1 . a] [2 . b]))))) + (test-suite "hash-equal?" + (test (check-true (hash-equal? #hash()))) + (test (check-false (hash-equal? #hasheq()))) + (test (check-false (hash-equal? #hasheqv())))) + (test-suite "hash-ref/check" + (test-ok (check-equal? (hash-ref/check #hash([1 . one] [2 . two]) 1) + 'one)) + (test-bad (hash-ref/check #hash([1 . one] [2 . two]) 3))) + (test-suite "hash-ref/identity" + (test-ok (check-equal? (hash-ref/identity #hash([1 . one] [2 . two]) 1) + 'one)) + (test-ok (check-equal? (hash-ref/identity #hash([1 . one] [2 . two]) 3) + 3))) + (test-suite "hash-ref/default" + (test-ok (check-equal? (hash-ref/default #hash([1 . one] [2 . two]) 1 '?) + 'one)) + (test-ok (check-equal? (hash-ref/default #hash([1 . one] [2 . two]) 3 '?) + '?))) + (test-suite "hash-ref/failure" + (test-ok (define x 7) + (define (f) (set! x (+ x 1)) x) + (check-equal? (hash-ref/failure #hash([1 . one] [2 . two]) 1 f) + 'one) + (check-equal? x 7) + (check-equal? (hash-ref/failure #hash([1 . one] [2 . two]) 3 f) + 8) + (check-equal? x 8))) + (test-suite "hash-has-key?" + (test-ok (check-equal? (hash-has-key? #hash([1 . one] [2 . two]) 1) #t)) + (test-ok (check-equal? (hash-has-key? #hash([1 . one] [2 . two]) 3) #f))) + (test-suite "hash-domain" + (test-ok (check-equal? (hash-domain #hash([1 . one] [2 . two])) '(1 2)))) + (test-suite "hash-range" + (test-ok (check-equal? (hash-range #hash([1 . one] [2 . two])) + '(one two)))) + (test-suite "hash-union" + (test-ok (hash-union #hash([1 . one] [2 . two]) + #hash([3 . three] [4 . four])) + #hash([4 . four] [3 . three] [1 . one] [2 . two]))) + (test-suite "hash-union!" + (test-ok (define h (make-hash)) + (hash-union! h #hash([1 . one] [2 . two])) + (hash-union! h #hash([3 . three] [4 . four])) + (check-equal? (hash-copy + #hash([1 . one] [2 . two] [3 . three] [4 . four])) + h))))) + diff --git a/collects/unstable/cce/test/test-main.ss b/collects/unstable/cce/test/test-main.ss new file mode 100644 index 0000000000..26406c3fdd --- /dev/null +++ b/collects/unstable/cce/test/test-main.ss @@ -0,0 +1,48 @@ +#lang scheme + +(require "checks.ss" + "test-class.ss" + "test-contract.ss" + "test-debug.ss" + "test-define.ss" + "test-dict.ss" + "test-exn.ss" + "test-function.ss" + "test-hash.ss" + "test-match.ss" + "test-planet.ss" + "test-port.ss" + "test-queue.ss" + "test-regexp.ss" + "test-require-provide.ss" + "test-sandbox.ss" + "test-scribble.ss" + "test-set.ss" + "test-syntax.ss" + "test-text.ss" + "test-values.ss" + "test-web.ss") + +(run-tests + (test-suite "scheme.plt" + class-suite + contract-suite + debug-suite + define-suite + dict-suite + exn-suite + function-suite + hash-suite + match-suite + planet-suite + port-suite + queue-suite + regexp-suite + require-provide-suite + sandbox-suite + scribble-suite + set-suite + syntax-suite + text-suite + values-suite + web-suite)) diff --git a/collects/unstable/cce/test/test-match.ss b/collects/unstable/cce/test/test-match.ss new file mode 100644 index 0000000000..8bc11a5a11 --- /dev/null +++ b/collects/unstable/cce/test/test-match.ss @@ -0,0 +1,45 @@ +#lang scheme + +(require "checks.ss" + "../match.ss") + +(provide match-suite) + +(define match-suite + (test-suite "match.ss" + (test-suite "match?" + (test + (check-true (match? (list 1 2 3) + (list a b c) + (vector x y z)))) + (test + (check-true (match? (vector 1 2 3) + (list a b c) + (vector x y z)))) + (test + (check-false (match? (+ 1 2 3) + (list a b c) + (vector x y z))))) + (test-suite "define-struct-pattern" + (test + (let () + (define-struct pair [a b] #:transparent) + (define-struct-pattern both pair) + (check-equal? + (match (make-pair 1 2) + [(both a b) (list a b)]) + (list 1 2))))) + (test-suite "as" + (test + (match (list 1 2 3) + [(as ([a 0]) (list b c d)) (list a b c d)]) + (list 0 1 2 3))) + (test-suite "$" + (test + (let () + (define-struct pair [a b] #:transparent) + (check-equal? ($ pair 1 2) (make-pair 1 2)) + (check-equal? + (match ($ pair 1 2) + [($ pair a b) (list a b)]) + (list 1 2))))))) diff --git a/collects/unstable/cce/test/test-planet.ss b/collects/unstable/cce/test/test-planet.ss new file mode 100644 index 0000000000..e4fecdd9a5 --- /dev/null +++ b/collects/unstable/cce/test/test-planet.ss @@ -0,0 +1,11 @@ +#lang scheme + +(require "checks.ss" + "../planet.ss" + planet/util) + +(provide planet-suite) + +(define planet-suite + (test-suite "planet.ss" + (test-suite "this-package-version-symbol"))) diff --git a/collects/unstable/cce/test/test-port.ss b/collects/unstable/cce/test/test-port.ss new file mode 100644 index 0000000000..52e7ea8df7 --- /dev/null +++ b/collects/unstable/cce/test/test-port.ss @@ -0,0 +1,52 @@ +#lang scheme + +(require "checks.ss" + "../port.ss") + +(provide port-suite) + +(define port-suite + (test-suite "port.ss" + (test-suite "eprintf" + (test + (parameterize ([current-error-port (open-output-string)]) + (eprintf "Danger, ~a!" "Will Robinson") + (check-equal? (get-output-string (current-error-port)) + "Danger, Will Robinson!")))) + (test-suite "read-all" + (test-ok (check-equal? (read-all read (open-input-string "1 2 3")) + (list 1 2 3))) + (test-ok (check-equal? + (parameterize ([current-input-port + (open-input-string "1 2 3")]) + (read-all)) + (list 1 2 3)))) + (test-suite "read-all-syntax" + (test-ok (check-equal? + (syntax->datum + (read-all-syntax read-syntax (open-input-string "1 2 3"))) + (list 1 2 3))) + (test-ok (check-equal? + (syntax->datum + (parameterize ([current-input-port + (open-input-string "1 2 3")]) + (read-all-syntax))) + (list 1 2 3)))) + + (test-suite "port->srcloc" + (test-ok (define port (open-input-string "\n x ")) + (port-count-lines! port) + (check-equal? (port->srcloc port) + (make-srcloc 'string 1 0 1 0)) + (read port) + (check-equal? (port->srcloc port 'here 1) + (make-srcloc 'here 2 2 4 1)))) + + (test-suite "read-available-bytes" + (test-ok (define-values [in out] (make-pipe)) + (check-equal? (read-available-bytes in) #"") + (write-byte (char->integer #\c) out) + (check-equal? (read-available-bytes in) #"c") + (close-output-port out) + (check-equal? (read-available-bytes in) eof))))) + diff --git a/collects/unstable/cce/test/test-queue.ss b/collects/unstable/cce/test/test-queue.ss new file mode 100644 index 0000000000..2857c879b0 --- /dev/null +++ b/collects/unstable/cce/test/test-queue.ss @@ -0,0 +1,56 @@ +#lang scheme + +(require "checks.ss" + "../queue.ss") + +(provide queue-suite) + +(define queue-suite + (test-suite "queue.ss" + (test-suite "queue-empty?" + (test-case "make-queue" + (check-true (queue-empty? (make-queue)))) + (test-case "enqueue! once" + (let* ([q (make-queue)]) + (enqueue! q 1) + (check-false (queue-empty? q)))) + (test-case "enqueue! once / dequeue! once" + (let* ([q (make-queue)]) + (enqueue! q 1) + (dequeue! q) + (check-true (queue-empty? q)))) + (test-case "enqueue! twice" + (let* ([q (make-queue)]) + (enqueue! q 1) + (enqueue! q 2) + (check-false (queue-empty? q)))) + (test-case "enqueue! twice / dequeue! once" + (let* ([q (make-queue)]) + (enqueue! q 1) + (enqueue! q 2) + (dequeue! q) + (check-false (queue-empty? q)))) + (test-case "enqueue! twice / dequeue! twice" + (let* ([q (make-queue)]) + (enqueue! q 1) + (enqueue! q 2) + (dequeue! q) + (dequeue! q) + (check-true (queue-empty? q))))) + (test-suite "dequeue!" + (test-case "make-queue" + (check-exn exn:fail:contract? (lambda () (dequeue! (make-queue))))) + (test-case "enqueue! once" + (let* ([q (make-queue)]) + (enqueue! q 1) + (check-equal? (dequeue! q) 1) + (check-exn exn:fail:contract? + (lambda () (dequeue! q))))) + (test-case "enqueue! twice" + (let* ([q (make-queue)]) + (enqueue! q 1) + (enqueue! q 2) + (check-equal? (dequeue! q) 1) + (check-equal? (dequeue! q) 2) + (check-exn exn:fail:contract? + (lambda () (dequeue! q)))))))) diff --git a/collects/unstable/cce/test/test-regexp.ss b/collects/unstable/cce/test/test-regexp.ss new file mode 100644 index 0000000000..0624427c59 --- /dev/null +++ b/collects/unstable/cce/test/test-regexp.ss @@ -0,0 +1,50 @@ +#lang scheme + +(require "checks.ss" "../regexp.ss") + +(provide regexp-suite) + +(define-syntax (regexp-test stx) + (syntax-case stx () + [(_ pattern string result) + (syntax/loc stx + (test-suite (format "(regexp-match ~s ~s) = ~s" 'pattern 'string 'result) + (test-case "regexp" + (check-equal? (regexp-match (regexp pattern) string) result)) + (test-case "pregexp" + (check-equal? (regexp-match (pregexp pattern) string) result))))])) + +(define regexp-suite + (test-suite "regexp.ss" + (test-suite "regexp-sequence" + (regexp-test (regexp-sequence) "a cat" (list "")) + (regexp-test (regexp-sequence "cat") "a cat" (list "cat")) + (regexp-test (regexp-sequence "hot" "dog") "a hotdog" (list "hotdog")) + (regexp-test (regexp-sequence "cat" "dog") "a cat" #f) + (regexp-test (regexp-sequence "cat" "dog") "a dog" #f) + (regexp-test (regexp-sequence "a" "b|c") "c" #f)) + (test-suite "regexp-or" + (regexp-test (regexp-or "cat") "a cat" (list "cat")) + (regexp-test (regexp-or "cat" "dog") "a cat" (list "cat")) + (regexp-test (regexp-or "cat" "dog") "a dog" (list "dog"))) + (test-suite "regexp-maybe" + (regexp-test (regexp-maybe "cat") "a dog" (list "")) + (regexp-test (regexp-maybe "cat") "catnap" (list "cat")) + (regexp-test (regexp-maybe "hot" "dog") "hotdog!" (list "hotdog")) + (regexp-test (regexp-maybe "hot" "dog") "a dog" (list ""))) + (test-suite "regexp-star" + (regexp-test (regexp-star "a") "" (list "")) + (regexp-test (regexp-star "a") "aaa" (list "aaa")) + (regexp-test (regexp-star "ab") "abab" (list "abab")) + (regexp-test (regexp-star "a" "b") "abab" (list "abab")) + (regexp-test (regexp-star "a" "b") "aaaa" (list ""))) + (test-suite "regexp-plus" + (regexp-test (regexp-plus "a") "" #f) + (regexp-test (regexp-plus "a") "aaa" (list "aaa")) + (regexp-test (regexp-plus "ab") "abab" (list "abab")) + (regexp-test (regexp-plus "a" "b") "abab" (list "abab")) + (regexp-test (regexp-plus "a" "b") "aaaa" #f)) + (test-suite "regexp-multi" + (regexp-test (regexp-multi "^cat$") "ant\nbat\ncat\ndog" (list "cat"))) + (test-suite "regexp-save" + (regexp-test (regexp-save "cat") "a cat" (list "cat" "cat"))))) diff --git a/collects/unstable/cce/test/test-require-provide.ss b/collects/unstable/cce/test/test-require-provide.ss new file mode 100644 index 0000000000..2cd37ab7a2 --- /dev/null +++ b/collects/unstable/cce/test/test-require-provide.ss @@ -0,0 +1,9 @@ +#lang scheme + +(require "checks.ss" + "../require-provide.ss") + +(provide require-provide-suite) + +(define require-provide-suite + (test-suite "require-provide.ss")) diff --git a/collects/unstable/cce/test/test-sandbox.ss b/collects/unstable/cce/test/test-sandbox.ss new file mode 100644 index 0000000000..646193692b --- /dev/null +++ b/collects/unstable/cce/test/test-sandbox.ss @@ -0,0 +1,9 @@ +#lang scheme + +(require "checks.ss" + "../sandbox.ss") + +(provide sandbox-suite) + +(define sandbox-suite + (test-suite "sandbox.ss")) diff --git a/collects/unstable/cce/test/test-scribble.ss b/collects/unstable/cce/test/test-scribble.ss new file mode 100644 index 0000000000..0dba507e8a --- /dev/null +++ b/collects/unstable/cce/test/test-scribble.ss @@ -0,0 +1,10 @@ +#lang scheme + +(require "checks.ss" + "../scribble.ss") + +(provide scribble-suite) + +(define scribble-suite + (test-suite "scribble.ss")) + diff --git a/collects/unstable/cce/test/test-set.ss b/collects/unstable/cce/test/test-set.ss new file mode 100644 index 0000000000..76bc7257bc --- /dev/null +++ b/collects/unstable/cce/test/test-set.ss @@ -0,0 +1,169 @@ +#lang scheme + +(require "checks.ss" + "../set.ss") + +(provide set-suite) + +(define (check/set a-set a-list #:= [== equal?]) + (check/sort (set->list a-set) a-list #:= ==)) + +(define-syntax-rule (test/set arg ...) + (test (check/set arg ...))) + +(define set-suite + (test-suite "set.ss" + (test-suite "Constructors" + (test-suite "set" + (test/set (set 1 2 3) (list 1 2 3)) + (test/set (set 3 2 1) (list 1 2 3)) + (test/set (set 3 1 2 #:mutable? #t) (list 1 2 3)) + (test/set (set 3 1 2 #:weak? #t) (list 1 2 3)) + (test/set (set 3 1 2 #:compare 'eqv) (list 1 2 3)) + (test/set (set 3 1 2 #:compare 'eq) (list 1 2 3))) + (test-suite "empty-set" + (test/set (empty-set) (list)) + (test/set (empty-set #:mutable? #t) (list)) + (test/set (empty-set #:weak? #t) (list)) + (test/set (empty-set #:compare 'eqv) (list)) + (test/set (empty-set #:compare 'eq) (list))) + (test-suite "list->set" + (test/set (list->set (list 1 2 3)) (list 1 2 3)) + (test/set (list->set (list 3 2 1)) (list 1 2 3)) + (test/set (list->set (list 3 1 2) #:mutable? #t) (list 1 2 3)) + (test/set (list->set (list 3 1 2) #:weak? #t) (list 1 2 3)) + (test/set (list->set (list 3 1 2) #:compare 'eqv) (list 1 2 3)) + (test/set (list->set (list 3 1 2) #:compare 'eq) (list 1 2 3))) + (test-suite "custom-set" + (test/set (custom-set #:compare string-ci=? "A" "a" "B" "b") + (list "A" "B") + #:= string-ci=?) + (test/set (custom-set #:compare string-ci=? + #:hash string-length + "A" "a" "B" "b") + (list "A" "B") + #:= string-ci=?) + (test/set (custom-set #:compare string-ci=? + #:hash string-length + #:mutable? #t + "A" "a" "B" "b") + (list "A" "B") + #:= string-ci=?))) + (test-suite "Accessors" + (test-suite "set-contains?" + (test (check-true (set-contains? (set 1 2 3) 1))) + (test (check-false (set-contains? (set 1 2 3) 4)))) + (test-suite "set-empty?" + (test (check-true (set-empty? (set)))) + (test (check-false (set-empty? (set 1 2 3))))) + (test-suite "set-count" + (test (check = (set-count (set)) 0)) + (test (check = (set-count (set 1 2 3)) 3))) + (test-suite "set=?" + (test (check-false (set=? (set 1) (set 1 2 3)))) + (test (check-false (set=? (set 1 2 3) (set 1)))) + (test (check-true (set=? (set 1 2 3) (set 1 2 3))))) + (test-suite "subset?" + (test (check-true (subset? (set 1) (set 1 2 3)))) + (test (check-false (subset? (set 1 2 3) (set 1)))) + (test (check-true (subset? (set 1 2 3) (set 1 2 3))))) + (test-suite "proper-subset?" + (test (check-true (proper-subset? (set 1) (set 1 2 3)))) + (test (check-false (proper-subset? (set 1 2 3) (set 1)))) + (test (check-false (proper-subset? (set 1 2 3) (set 1 2 3))))) + (test-suite "set->list" + (test (check/sort (set->list (set 1 2 3)) (list 1 2 3)))) + (test-suite "in-set" + (test (check/sort (for/list ([x (in-set (set 1 2 3))]) x) + (list 1 2 3))))) + (test-suite "Updaters" + (test-suite "set-insert" + (test/set (set-insert (set 1 2 3) 4) (list 1 2 3 4)) + (test/set (set-insert (set 1 2 3) 1) (list 1 2 3))) + (test-suite "set-remove" + (test/set (set-remove (set 1 2 3) 1) (list 2 3)) + (test/set (set-remove (set 1 2 3) 4) (list 1 2 3))) + (test-suite "set-insert!" + (test (let* ([s (set 1 2 3 #:mutable? #t)]) + (set-insert! s 4) + (check/set s (list 1 2 3 4)))) + (test (let* ([s (set 1 2 3 #:mutable? #t)]) + (set-insert! s 1) + (check/set s (list 1 2 3))))) + (test-suite "set-remove!" + (test (let* ([s (set 1 2 3 #:mutable? #t)]) + (set-remove! s 1) + (check/set s (list 2 3)))) + (test (let* ([s (set 1 2 3 #:mutable? #t)]) + (set-remove! s 4) + (check/set s (list 1 2 3))))) + (test-suite "set-union" + (test/set (set-union (set 1 2) (set 1 3) (set 2 3)) (list 1 2 3)) + (test/set (set-union (set) (set 1 2) (set 3 4)) (list 1 2 3 4)) + (test/set (set-union (set 1 2) (set) (set 3 4)) (list 1 2 3 4)) + (test/set (set-union (set 1 2) (set 3 4) (set)) (list 1 2 3 4))) + (test-suite "set-intersection" + (test/set (set-intersection (set 1 2 3) (set 1 2) (set 2 3)) (list 2)) + (test/set (set-intersection (set 1 2) (set 1 2 3) (set 2 3)) (list 2)) + (test/set (set-intersection (set 1 2) (set 2 3) (set 1 2 3)) (list 2)) + (test/set (set-intersection (set 1 2) (set 2 3) (set 1 3)) (list))) + (test-suite "set-difference" + (test/set (set-difference (set 1 2 3) (set 1) (set 3)) (list 2)) + (test/set (set-difference (set 1 2 3 4) (set 5) (set 6)) (list 1 2 3 4)) + (test/set (set-difference (set 1 2 3) (set 1 2) (set 2 3)) (list))) + (test-suite "set-exclusive-or" + (test/set (set-exclusive-or (set 1) (set 1 2) (set 1 2 3)) (list 1 3)) + (test/set (set-exclusive-or (set 1) (set 2) (set 3)) (list 1 2 3)) + (test/set (set-exclusive-or (set 1 2) (set 2 3) (set 1 3)) (list)))) + (test-suite "Predicates" + (test-suite "set?" + (test (check-false (set? '(1 2)))) + (test (check-true (set? '((1 . one) (2 . two))))) + (test (check-true (set? (set 1 2 3))))) + (test-suite "set-can-insert?" + (test (check-true (set-can-insert? (set 1 2 3)))) + (test (check-false (set-can-insert? (set 1 2 3 #:mutable? #t))))) + (test-suite "set-can-remove?" + (test (check-true (set-can-remove? (set 1 2 3)))) + (test (check-false (set-can-remove? (set 1 2 3 #:mutable? #t))))) + (test-suite "set-can-insert!?" + (test (check-false (set-can-insert!? (set 1 2 3)))) + (test (check-true (set-can-insert!? (set 1 2 3 #:mutable? #t))))) + (test-suite "set-can-remove!?" + (test (check-false (set-can-remove!? (set 1 2 3)))) + (test (check-true (set-can-remove!? (set 1 2 3 #:mutable? #t)))))) + (test-suite "Property" + (test-suite "prop:set" + (test + (let () + (define (never-contains? set elem) #f) + (define (never-remove! set elem) (void)) + (define (never-remove set elem) set) + (define (always-zero set) 0) + (define (no-elements set) null) + + (define-struct always-empty [] + #:transparent + #:property prop:set + (vector never-contains? + #f + #f + never-remove! + never-remove + always-zero + no-elements)) + + (check-true (set? (make-always-empty))) + (check/set (make-always-empty) (list)) + (check-false (set-contains? (make-always-empty) 1)) + (check-bad (set-insert! (make-always-empty) 2)) + (check-bad (set-insert (make-always-empty) 3)) + (check/set (let* ([s (make-always-empty)]) + (set-remove! s 4) + s) + (list)) + (check/set (set-remove (make-always-empty) 5) (list)) + (check-true (set-empty? (make-always-empty))) + (check-equal? (set->list (make-always-empty)) (list)))))))) + + diff --git a/collects/unstable/cce/test/test-syntax.ss b/collects/unstable/cce/test/test-syntax.ss new file mode 100644 index 0000000000..5fdf647cb0 --- /dev/null +++ b/collects/unstable/cce/test/test-syntax.ss @@ -0,0 +1,256 @@ +#lang scheme + +(require mzlib/etc + planet/util + "checks.ss" + "../syntax.ss") + +(provide syntax-suite) + +(define here + (datum->syntax + #f + 'here + (list (build-path (this-expression-source-directory) + (this-expression-file-name)) + 1 1 1 1))) + +(define syntax-suite + (test-suite "syntax.ss" + + (test-suite "Contracts" + + (test-suite "syntax-datum/c" + (test-ok (with/c (syntax-datum/c (listof (listof natural-number/c))) + #'((0 1 2) () (3 4) (5)))) + (test-bad (with/c (syntax-datum/c (listof (listof natural-number/c))) + #'((x y z)))) + (test-bad (with/c (syntax-datum/c string?) "xyz"))) + + (test-suite "syntax-listof/c" + (test-ok (with/c (syntax-listof/c identifier?) #'(a b c))) + (test-bad (with/c (syntax-listof/c identifier?) #'(1 2 3))) + (test-bad (with/c (syntax-listof/c identifier?) #'(a b . c))) + (test-bad (with/c (syntax-listof/c identifier?) (list #'a #'b #'c)))) + + (test-suite "syntax-list/c" + (test-ok (with/c (syntax-list/c identifier? (syntax/c string?)) + #'(a "b"))) + (test-bad (with/c (syntax-list/c identifier? (syntax/c string?)) + #'(a "b" #:c))) + (test-bad (with/c (syntax-list/c identifier? (syntax/c string?)) + #'(a b))) + (test-bad (with/c (syntax-list/c identifier? (syntax/c string?)) + #'(a "b" . c))) + (test-bad (with/c (syntax-list/c identifier? (syntax/c string?)) + '(#'a #'"b"))))) + + (test-suite "Source Location Representations" + + (test-suite "src/c" + (test-ok (with/c src/c #f)) + (test-ok (with/c src/c (make-srcloc 'source 1 0 1 0))) + (test-ok (with/c src/c #'here)) + (test-ok (with/c src/c (list 'source 1 0 1 0))) + (test-bad (with/c src/c (list 'source 1 0 0 1))) + (test-bad (with/c src/c (list 'source 0 0 0 0))) + (test-ok (with/c src/c (vector 'source 1 0 1 0))) + (test-bad (with/c src/c (vector 'source 1 0 0 1))) + (test-bad (with/c src/c (vector 'source 0 0 0 0))) + (test-bad (with/c src/c 'symbol))) + + (test-suite "src->srcloc" + (test-ok (check-equal? (src->srcloc #f) (make-srcloc #f #f #f #f #f))) + (test-ok (check-equal? (src->srcloc (make-srcloc 'source 1 0 1 0)) + (make-srcloc 'source 1 0 1 0))) + (test-ok (check-equal? (src->srcloc (datum->syntax #f 'here #f)) + ;; Note known bug w/ syntax-span: + (make-srcloc #f #f #f #f 0))) + (test-ok (check-equal? (src->srcloc (list 'source 1 0 1 0)) + (make-srcloc 'source 1 0 1 0))) + (test-ok (check-equal? (src->srcloc (vector 'source 1 0 1 0)) + (make-srcloc 'source 1 0 1 0))) + (test-ok (check-equal? (src->srcloc) (make-srcloc #f #f #f #f #f))) + (test-ok (check-equal? (src->srcloc (make-srcloc 'one 1 0 1 0) + (make-srcloc 'two 1 0 1 0)) + (make-srcloc #f #f #f #f #f))) + (test-ok (check-equal? (src->srcloc (make-srcloc 'source 1 0 1 0) + (make-srcloc 'source 2 1 2 1)) + (make-srcloc 'source 1 0 1 2)))) + + (test-suite "src->list" + (test-ok (check-equal? (src->list #f) (list #f #f #f #f #f))) + (test-ok (check-equal? (src->list (make-srcloc 'source 1 0 1 0)) + (list 'source 1 0 1 0))) + (test-ok (check-equal? (src->list (datum->syntax #f 'here #f)) + ;; Note known bug w/ syntax-span: + (list #f #f #f #f 0))) + (test-ok (check-equal? (src->list (list 'source 1 0 1 0)) + (list 'source 1 0 1 0))) + (test-ok (check-equal? (src->list (vector 'source 1 0 1 0)) + (list 'source 1 0 1 0))) + (test-ok (check-equal? (src->list) (list #f #f #f #f #f))) + (test-ok (check-equal? (src->list (make-srcloc 'one 1 0 1 0) + (make-srcloc 'two 1 0 1 0)) + (list #f #f #f #f #f))) + (test-ok (check-equal? (src->list (make-srcloc 'source 1 0 1 0) + (make-srcloc 'source 2 1 2 1)) + (list 'source 1 0 1 2)))) + + (test-suite "src->vector" + (test-ok (check-equal? (src->vector #f) (vector #f #f #f #f #f))) + (test-ok (check-equal? (src->vector (make-srcloc 'source 1 0 1 0)) + (vector 'source 1 0 1 0))) + (test-ok (check-equal? (src->vector (datum->syntax #f 'here #f)) + ;; Note known bug w/ syntax-span: + (vector #f #f #f #f 0))) + (test-ok (check-equal? (src->vector (list 'source 1 0 1 0)) + (vector 'source 1 0 1 0))) + (test-ok (check-equal? (src->vector (vector 'source 1 0 1 0)) + (vector 'source 1 0 1 0))) + (test-ok (check-equal? (src->vector) (vector #f #f #f #f #f))) + (test-ok (check-equal? (src->vector (make-srcloc 'one 1 0 1 0) + (make-srcloc 'two 1 0 1 0)) + (vector #f #f #f #f #f))) + (test-ok (check-equal? (src->vector (make-srcloc 'source 1 0 1 0) + (make-srcloc 'source 2 1 2 1)) + (vector 'source 1 0 1 2)))) + + (test-suite "src->syntax" + (test-ok (check-pred syntax? (src->syntax #f))) + (test-ok (check-pred syntax? + (src->syntax (make-srcloc 'source 1 0 1 0)))) + (test-ok (check-pred syntax? (src->syntax (datum->syntax #f 'here #f)))) + (test-ok (check-pred syntax? (src->syntax (list 'source 1 0 1 0)))) + (test-ok (check-pred syntax? (src->syntax (vector 'source 1 0 1 0)))) + (test-ok (check-pred syntax? (src->syntax))) + (test-ok (check-pred syntax? (src->syntax (make-srcloc 'one 1 0 1 0) + (make-srcloc 'two 1 0 1 0)))) + (test-ok (check-pred syntax? + (src->syntax (make-srcloc 'source 1 0 1 0) + (make-srcloc 'source 2 1 2 1))))) + + (test-suite "src-known?" + (test-ok (check-false (src-known? (list #f #f #f #f #f)))) + (test-ok (check-true (src-known? (vector 'source #f #f #f #f)))) + (test-ok (check-true (src-known? (datum->syntax #f 'x + (list 'a 1 2 3 4))))))) + + (test-suite "Syntax Lists" + + (test-suite "syntax-list" + (test + (check-equal? + (with-syntax ([([x ...] ...) #'([1 2] [3] [4 5 6])]) + (map syntax->datum (syntax-list x ... ...))) + (list 1 2 3 4 5 6)))) + + (test-suite "syntax-map" + (test-case "identifiers to symbols" + (check-equal? (syntax-map syntax-e #'(a b c)) '(a b c))))) + + (test-suite "Syntax Conversions" + + (test-suite "to-syntax" + (test-case "symbol + context = identifier" + (check bound-identifier=? + (to-syntax #:stx #'context 'id) + #'id))) + + (test-suite "to-datum" + (test-case "syntax" + (check-equal? (to-datum #'((a b) () (c))) + '((a b) () (c)))) + (test-case "non-syntax" + (check-equal? (to-datum '((a b) () (c))) + '((a b) () (c)))) + (test-case "nested syntax" + (let* ([stx-ab #'(a b)] + [stx-null #'()] + [stx-c #'(c)]) + (check-equal? (to-datum (list stx-ab stx-null stx-c)) + (list stx-ab stx-null stx-c)))))) + + (test-suite "Syntax Source Locations" + + (test-suite "syntax-source-file-name" + (test-case "here" + (check-equal? (syntax-source-file-name here) + (this-expression-file-name))) + (test-case "fail" + (check-equal? (syntax-source-file-name (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-directory" + (test-case "here" + (check-equal? (syntax-source-directory here) + (this-expression-source-directory))) + (test-case "fail" + (check-equal? (syntax-source-directory (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-planet-package" + (test-case "fail" + (check-equal? (syntax-source-planet-package (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-planet-package-owner" + (test-case "fail" + (check-equal? (syntax-source-planet-package-owner + (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-planet-package-name" + (test-case "fail" + (check-equal? (syntax-source-planet-package-name + (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-planet-package-major" + (test-case "fail" + (check-equal? (syntax-source-planet-package-major + (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-planet-package-minor" + (test-case "fail" + (check-equal? (syntax-source-planet-package-minor + (datum->syntax #f 'fail)) + #f))) + + (test-suite "syntax-source-planet-package-symbol" + (test-case "fail" + (check-equal? (syntax-source-planet-package-minor + (datum->syntax #f 'fail)) + #f))) + + (test-suite "make-planet-path")) + + (test-suite "Transformers" + + (test-suite "redirect-transformer" + (test (check-equal? + (syntax->datum ((redirect-transformer #'x) #'y)) + 'x)) + (test (check-equal? + (syntax->datum ((redirect-transformer #'x) #'(y z))) + '(x z)))) + + (test-suite "full-kernel-form-identifier-list" + (test (check-pred list? (full-kernel-form-identifier-list))) + (test (for ([id (in-list (full-kernel-form-identifier-list))]) + (check-pred identifier? id)))) + + (test-suite "head-expand") + + (test-suite "trampoline-transformer") + + (test-suite "quote-transformer")) + + (test-suite "Pattern Bindings" + + (test-suite "with-syntax*" + (test-case "identifier" + (check bound-identifier=? + (with-syntax* ([a #'id] [b #'a]) #'b) + #'id)))))) diff --git a/collects/unstable/cce/test/test-text.ss b/collects/unstable/cce/test/test-text.ss new file mode 100644 index 0000000000..609ff624ec --- /dev/null +++ b/collects/unstable/cce/test/test-text.ss @@ -0,0 +1,136 @@ +#lang scheme + +(require "checks.ss" + "../text.ss") + +(provide text-suite) + +(define text-suite + (test-suite "text.ss" + (test-suite "text/c" + (test-ok (with/c text/c "text")) + (test-ok (with/c text/c #"text")) + (test-ok (with/c text/c 'text)) + (test-ok (with/c text/c '#:text)) + (test-ok (with/c text/c #'"text")) + (test-ok (with/c text/c #'#"text")) + (test-ok (with/c text/c #'text)) + (test-ok (with/c text/c #'#:text)) + (test-bad (with/c text/c '(not text)))) + (test-suite "text?" + (test-case "accept string" + (check-pred text? "text")) + (test-case "accept byte string" + (check-pred text? #"text")) + (test-case "accept symbol" + (check-pred text? 'text)) + (test-case "accept keyword" + (check-pred text? '#:text)) + (test-case "accept string literal" + (check-pred text? #'"text")) + (test-case "accept byte string literal" + (check-pred text? #'#"text")) + (test-case "accept identifier" + (check-pred text? #'text)) + (test-case "accept keyword literal" + (check-pred text? #'#:text)) + (test-case "reject non-text" + (check-false (text? '(not text))))) + (test-suite "string-literal?" + (test-case "accept" (check-true (string-literal? #'"string"))) + (test-case "reject" (check-false (string-literal? "string")))) + (test-suite "keyword-literal?" + (test-case "accept" (check-true (keyword-literal? #'#:keyword))) + (test-case "reject" (check-false (keyword-literal? '#:keyword)))) + (test-suite "bytes-literal?" + (test-case "accept" (check-true (bytes-literal? #'#"bytes"))) + (test-case "reject" (check-false (bytes-literal? #"bytes")))) + (test-suite "text=?" + (test-case "string = string" + (check text=? "abc" (string-copy "abc"))) + (test-case "string != string" + (check-not text=? "abc" (string-copy "cba"))) + (test-case "string = identifier" + (check text=? "car" #'car)) + (test-case "string != identifier" + (check-not text=? "car" #'cdr)) + (test-case "identifier = identifier, different bindings" + (check text=? #'car (datum->syntax #f 'car))) + (test-case "identifier != identifier, no bindings" + (check-not text=? #'UNBOUND (datum->syntax #f 'ALSO-UNBOUND)))) + (test-suite "text?" + (test-case "string > string" + (check text>? "def" "abc")) + (test-case "string !> string" + (check-not text>? "abc" "abc")) + (test-case "string > identifier" + (check text>? "def" #'abc)) + (test-case "string !> identifier" + (check-not text>? "abc" #'abc))) + (test-suite "text>=?" + (test-case "string >= string" + (check text>=? "abc" "abc")) + (test-case "string !>= string" + (check-not text>=? "abc" "def")) + (test-case "string >= identifier" + (check text>=? "abc" #'abc)) + (test-case "string !>= identifier" + (check-not text>=? "abc" #'def))) + (test-suite "text->string" + (test-case "single" (check-equal? (text->string 'abc) "abc")) + (test-case "multiple" (check-equal? (text->string 'a "b" #'c) "abc"))) + (test-suite "text->symbol" + (test-case "single" (check-equal? (text->symbol "abc") 'abc)) + (test-case "multiple" (check-equal? (text->symbol 'a "b" #'c) 'abc))) + (test-suite "text->keyword" + (test-case "single" (check-equal? (text->keyword #'abc) '#:abc)) + (test-case "multiple" (check-equal? (text->keyword 'a "b" #'c) '#:abc))) + (test-suite "text->bytes" + (test-case "single" (check-equal? (text->bytes "abc") #"abc")) + (test-case "multiple" (check-equal? (text->bytes 'a "b" #'c) #"abc"))) + (test-suite "text->identifier" + (test-case "single, no context" + (check-equal? (syntax-e (text->identifier "abc")) 'abc)) + (test-case "multiple w/ context" + (check bound-identifier=? + (text->identifier #:stx #'here 'a "b" #'c) + #'abc))) + (test-suite "text->string-literal" + (test-case "single" + (check-equal? (syntax-e (text->string-literal '#:abc)) "abc")) + (test-case "multiple" + (check-equal? + (syntax-e (text->string-literal #:stx #'here 'a "b" #'c)) + "abc"))) + (test-suite "text->keyword-literal" + (test-case "single" + (check-equal? (syntax-e (text->keyword-literal #"abc")) '#:abc)) + (test-case "multiple" + (check-equal? + (syntax-e (text->keyword-literal #:stx #'here 'a "b" #'c)) + '#:abc))) + (test-suite "text->bytes-literal" + (test-case "single" + (check-equal? (syntax-e (text->bytes-literal 'abc)) #"abc")) + (test-case "multiple" + (check-equal? + (syntax-e (text->bytes-literal #:stx #'here 'a "b" #'c)) + #"abc"))))) diff --git a/collects/unstable/cce/test/test-values.ss b/collects/unstable/cce/test/test-values.ss new file mode 100644 index 0000000000..9871560b61 --- /dev/null +++ b/collects/unstable/cce/test/test-values.ss @@ -0,0 +1,63 @@ +#lang scheme + +(require "checks.ss" + "../values.ss") + +(provide values-suite) + +(define values-suite + (test-suite "values.ss" + (test-suite "map2" + (test-case "numerator and denominator" + (let*-values ([(ns ds) + (map2 + (lambda (r) + (values (numerator r) (denominator r))) + (list 1/2 3/4 5/6))]) + (check-equal? (list ns ds) (list '(1 3 5) '(2 4 6)))))) + (test-suite "map/values" + (test-case "complex numerator and denominator" + (let*-values ([(rns rds ins ids) + (map/values + 4 + (lambda (c) + (values (numerator (real-part c)) + (denominator (real-part c)) + (numerator (imag-part c)) + (denominator (imag-part c)))) + (list 1/2+3/4i 5/6+7/8i))]) + (check-equal? (list rns rds ins ids) + (list '(1 5) '(2 6) '(3 7) '(4 8))))) + (test-case "multiple lists" + (let*-values ([(as bs cs) + (map/values 3 values '(1 2 3) '(4 5 6) '(7 8 9))]) + (check-equal? as '(1 2 3)) + (check-equal? bs '(4 5 6)) + (check-equal? cs '(7 8 9))))) + (test-suite "foldl/values" + (test-case "sum, product, and last" + (let*-values ([(sum prod last) + (foldl/values + (lambda (next sum prod last) + (values (+ next sum) + (* next prod) + next)) + (list 0 1 #f) + (list 1 2 3 4))]) + (check-equal? (list sum prod last) + (list 10 24 4))))) + (test-suite "foldr/values" + (test-case "sum, product, and last" + (let*-values ([(sum prod last) + (foldr/values + (lambda (next sum prod last) + (values (+ next sum) + (* next prod) + next)) + (list 0 1 #f) + (list 1 2 3 4))]) + (check-equal? (list sum prod last) + (list 10 24 1))))) + (test-suite "values->list" + (test-case "1 2 3 4" + (check-equal? (values->list (values 1 2 3 4)) (list 1 2 3 4)))))) diff --git a/collects/unstable/cce/test/test-web.ss b/collects/unstable/cce/test/test-web.ss new file mode 100644 index 0000000000..4c231cd4c7 --- /dev/null +++ b/collects/unstable/cce/test/test-web.ss @@ -0,0 +1,22 @@ +#lang scheme + +(require "checks.ss" + "../web.ss") + +(provide web-suite) + +(define web-suite + (test-suite "web.ss" + (test-suite "css?" + (test-true "CSS" (css? '((foo (a b) (c d)) (bar (w x) (y z))))) + (test-false "not CSS" (css? '(a b c d)))) + (test-suite "css/c" + (test-ok "CSS" (with/c css/c '((foo (a b) (c d)) (bar (w x) (y z))))) + (test-bad "not CSS" (with/c css/c '(a b c d)))) + (test-suite "xexpr/c" + (test-ok "XExpr" (with/c xexpr/c '(a ([href "url"]) "somewhere"))) + (test-bad "not XExpr" (with/c xexpr/c '(a ("href" url) . "nowhere")))) + (test-suite "write-css") + (test-suite "write-xexpr") + (test-suite "create-stylesheet") + (test-suite "create-webpage"))) diff --git a/collects/unstable/cce/text.ss b/collects/unstable/cce/text.ss new file mode 100644 index 0000000000..9a50817714 --- /dev/null +++ b/collects/unstable/cce/text.ss @@ -0,0 +1,129 @@ +#lang scheme/base + +(require scheme/list scheme/match scheme/contract) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; TEXT DATATYPE +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (literal? pred? v) + (and (syntax? v) (pred? (syntax-e v)))) + +(define (string-literal? v) (literal? string? v)) +(define (bytes-literal? v) (literal? bytes? v)) +(define (keyword-literal? v) (literal? keyword? v)) + +(define (text? v) + (or (symbol? v) + (string? v) + (keyword? v) + (bytes? v) + (and (syntax? v) (text? (syntax-e v))))) + +(define (text=? a b) + (string=? (to-string a) (to-string b))) + +(define (text>? a b) + (string>? (to-string a) (to-string b))) + +(define (text>=? a b) + (string>=? (to-string a) (to-string b))) + +(define (textstring t)] + [(keyword? t) (keyword->string t)] + [(bytes? t) (bytes->string/utf-8 t)] + [(syntax? t) (to-string (syntax-e t))])) + +(define (combine-strings before between after strs) + (apply + string-append + before + (let loop ([strs strs]) + (match strs + [(list) (list after)] + [(list str) (list str after)] + [(cons str strs) (list* str between (loop strs))])))) + +(define ((to-text convert) + #:before [before ""] + #:between [between ""] + #:after [after ""] + . ts) + (convert (combine-strings (to-string before) + (to-string between) + (to-string after) + (map to-string ts)))) + +(define text->string (to-text values)) +(define text->symbol (to-text string->symbol)) +(define text->keyword (to-text string->keyword)) +(define text->bytes (to-text string->bytes/utf-8)) + +(define ((to-literal convert) + #:stx [stx #f] + #:before [before ""] + #:between [between ""] + #:after [after ""] + . ts) + (datum->syntax + stx + (convert (combine-strings (to-string before) + (to-string between) + (to-string after) + (map to-string ts))) + stx + stx + stx)) + +(define text->string-literal (to-literal values)) +(define text->identifier (to-literal string->symbol)) +(define text->keyword-literal (to-literal string->keyword)) +(define text->bytes-literal (to-literal string->bytes/utf-8)) + +(define text/c (flat-named-contract "text" text?)) + +(define (convert/c result/c) + (->* [] + [#:before text/c #:between text/c #:after text/c] + #:rest (listof text/c) + result/c)) + +(define (convert-literal/c result/c) + (->* [] + [#:before text/c + #:between text/c + #:after text/c + #:stx (or/c false/c syntax?)] + #:rest (listof text/c) + result/c)) + +(provide/contract + [text/c flat-contract?] + [text? (-> any/c boolean?)] + [string-literal? (-> any/c boolean?)] + [keyword-literal? (-> any/c boolean?)] + [bytes-literal? (-> any/c boolean?)] + [text=? (-> text/c text/c boolean?)] + [text>? (-> text/c text/c boolean?)] + [text>=? (-> text/c text/c boolean?)] + [text text/c text/c boolean?)] + [text<=? (-> text/c text/c boolean?)] + [text->string (convert/c string?)] + [text->symbol (convert/c symbol?)] + [text->keyword (convert/c keyword?)] + [text->bytes (convert/c bytes?)] + [text->identifier (convert-literal/c identifier?)] + [text->string-literal (convert-literal/c string-literal?)] + [text->keyword-literal (convert-literal/c keyword-literal?)] + [text->bytes-literal (convert-literal/c bytes-literal?)]) diff --git a/collects/unstable/cce/values.ss b/collects/unstable/cce/values.ss new file mode 100644 index 0000000000..a622c4ed0f --- /dev/null +++ b/collects/unstable/cce/values.ss @@ -0,0 +1,63 @@ +#lang scheme/base +(require (for-syntax scheme/base)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; MULTIPLE VALUES TOOLS +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (values->list stx) + (syntax-case stx () + [(vl expr) + (syntax/loc stx + (call-with-values (lambda () expr) list))])) + +(define (map/list n f ls) + (cond + [(andmap null? ls) (build-list n (lambda (i) null))] + [(andmap pair? ls) + (let* ([vs (values->list (apply f (map car ls)))] + [k (length vs)]) + (unless (= k n) + (error 'map/values + "~a produced ~a values, not ~a: ~e" + f k n vs)) + (map cons vs (map/list n f (map cdr ls))))] + [else (error 'map/values "list lengths differ")])) + +(define (map/values n f . ls) + (apply values (map/list n f ls))) + +(define (map2 f . ls) + (apply values (map/list 2 f ls))) + +(define (foldr/list f vs ls) + (cond + [(andmap null? ls) vs] + [(andmap pair? ls) + (values->list + (apply + f + (append + (map car ls) + (foldr/list f vs (map cdr ls)))))] + [else (error 'foldr/values "list lengths differ")])) + +(define (foldr/values f vs . ls) + (apply values (foldr/list f vs ls))) + +(define (foldl/list f vs ls) + (cond + [(andmap null? ls) vs] + [(andmap pair? ls) + (foldl/list + f + (values->list (apply f (append (map car ls) vs))) + (map cdr ls))] + [else (error 'foldl/values "list lengths differ")])) + +(define (foldl/values f vs . ls) + (apply values (foldl/list f vs ls))) + +(provide map2 map/values foldr/values foldl/values values->list) diff --git a/collects/unstable/cce/web.ss b/collects/unstable/cce/web.ss new file mode 100644 index 0000000000..2aea1e31f5 --- /dev/null +++ b/collects/unstable/cce/web.ss @@ -0,0 +1,98 @@ +#lang scheme +(require xml + "define.ss" + "function.ss" + "text.ss") + +;; css/c : FlatContract +;; Recognizes representations of Cascading Style Sheets. +(define css/c (listof (cons/c text/c (listof (list/c text/c text/c))))) + +(provide/contract + [css/c flat-contract?] + [css? (-> any/c boolean?)] + [write-css (->* [css/c] [output-port?] void?)]) + +;; A Cascading Style Sheet (CSS) is a (Listof StyleDefn) +;; A Style Definition (StyleDefn) is a (cons Selectors (Listof PropDefn)) +;; A Selectors is a Selector or a (NonEmptyListof Selector) +;; A Selector is a Symbol or String +;; A Property Definition (PropDefn) is a (list PropName PropVal) +;; A Property Name (PropName) is a Symbol or String +;; A Property Value (PropVal) is a Symbol or String + +;; css? : Any -> Boolean +;; Reports whether a value is a CSS. +(define css? (flat-contract-predicate css/c)) + +;; write-css : CSS [OutputPort] -> Void +;; Writes a CSS datastructure as a proper text Cascading Style Sheet. +(define write-css + (lambda/parameter (css [output #:param current-output-port]) + (for-each write-style-defn css))) + +;; write-style-defn : StyleDefn [OutputPort] -> Void +;; Writes a style definition to a Cascading Style Sheet. +(define write-style-defn + (lambda/parameter (style-defn [output #:param current-output-port]) + (write-selector (car style-defn)) + (display " {") + (for-each write-prop-defn (cdr style-defn)) + (display " }\n"))) + +;; write-text : Text [OutputPort] -> Void +;; Writes a text field to a Cascading Style Sheet. +(define write-text + (lambda/parameter (text [output #:param current-output-port]) + (display (text->string text)))) + +;; write-selector : Selector [OutputPort] -> Void +;; Writes a selector to a Cascading Style Sheet. +(define write-selector write-text) + +;; write-prop-defn : PropDefn [OutputPort] -> Void +;; Writes a property definition to a Cascading Style Sheet. +(define write-prop-defn + (lambda/parameter (prop-defn [output #:param current-output-port]) + (display " ") + (write-prop-name (car prop-defn)) + (display " : ") + (write-prop-val (cadr prop-defn)) + (display ";"))) + +;; write-prop-name : PropName [OutputPort] -> Void +;; Writes a property name to a Cascading Style Sheet. +(define write-prop-name write-text) + +;; write-prop-val : PropVal [OutputPort] -> Void +;; Writes a property value to a Cascading Style Sheet. +(define write-prop-val write-text) + +(define-if-unbound xexpr/c + (flat-named-contract "Xexpr" xexpr?)) + +(provide xexpr/c) +(provide/contract + [write-xexpr (->* [xexpr/c] [output-port?] void?)]) + +(define write-xexpr + (lambda/parameter (xexpr [output #:param current-output-port]) + (write-xml/content (xexpr->xml xexpr)))) + +(provide/contract + [create-webpage (string? xexpr/c . -> . void?)] + [create-stylesheet (string? css/c . -> . void?)]) + +;; create-stylesheet : String CSS -> Void +;; Writes an individual stylesheet to a file. +(define (create-stylesheet filename css) + (let* ([out-port (open-output-file filename #:exists 'replace)]) + (write-css css out-port) + (close-output-port out-port))) + +;; create-webpage : String XExpr -> Void +;; Writes an individual webpage to a file. +(define (create-webpage filename xexpr) + (let* ([out-port (open-output-file filename #:exists 'replace)]) + (write-xexpr xexpr out-port) + (close-output-port out-port))) diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index bcc223f27b..daa29326ea 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -98,6 +98,9 @@ Keep documentation and tests up to date. @include-section["debug.scrbl"] @include-section["byte-counting-port.scrbl"] +;; This addition is temporary while integrating (planet cce/scheme:7): +@include-section["../cce/reference/manual.scrbl"] + @;{--------} @;{