From 6bcf77fe65174bee921df03d10c1ed038657c0f9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 29 May 2010 00:23:21 -0400 Subject: [PATCH] Moved unstable/cce/text to unstable/text. --- collects/tests/unstable/helpers.rkt | 19 ++- collects/tests/unstable/text.rkt | 133 +++++++++++++++++ collects/unstable/cce/private/syntax-core.ss | 2 +- collects/unstable/cce/reference/manual.scrbl | 1 - collects/unstable/cce/reference/web.scrbl | 3 +- collects/unstable/cce/syntax.ss | 4 +- collects/unstable/cce/test/test-main.ss | 2 - collects/unstable/cce/test/test-text.ss | 136 ------------------ collects/unstable/cce/web.ss | 4 +- .../{cce/reference => scribblings}/text.scrbl | 24 ++-- collects/unstable/scribblings/unstable.scrbl | 1 + collects/unstable/{cce/text.ss => text.rkt} | 4 +- 12 files changed, 172 insertions(+), 161 deletions(-) create mode 100644 collects/tests/unstable/text.rkt delete mode 100644 collects/unstable/cce/test/test-text.ss rename collects/unstable/{cce/reference => scribblings}/text.scrbl (92%) rename collects/unstable/{cce/text.ss => text.rkt} (98%) diff --git a/collects/tests/unstable/helpers.rkt b/collects/tests/unstable/helpers.rkt index 179552ea38..f5a11728a1 100644 --- a/collects/tests/unstable/helpers.rkt +++ b/collects/tests/unstable/helpers.rkt @@ -2,7 +2,9 @@ (provide test test-ok check-ok - test-bad check-bad) + test-bad check-bad + check-not + with/c) (require rackunit racket/pretty) @@ -18,3 +20,18 @@ (define (pretty-format/write x) (with-output-to-string (lambda () (pretty-write x)))) + +(define-syntax-rule (with/c c e) + (let () (with-contract value ([value c]) (define value e)) value)) + +(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)))))))) diff --git a/collects/tests/unstable/text.rkt b/collects/tests/unstable/text.rkt new file mode 100644 index 0000000000..8f5e37aaba --- /dev/null +++ b/collects/tests/unstable/text.rkt @@ -0,0 +1,133 @@ +#lang racket + +(require rackunit rackunit/text-ui unstable/text "helpers.rkt") + +(run-tests + (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/private/syntax-core.ss b/collects/unstable/cce/private/syntax-core.ss index c549e94977..7fc689a198 100644 --- a/collects/unstable/cce/private/syntax-core.ss +++ b/collects/unstable/cce/private/syntax-core.ss @@ -2,8 +2,8 @@ (require scheme/contract scheme/match + unstable/text (only-in unstable/syntax with-syntax*) - "../text.ss" (for-syntax scheme/base)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/unstable/cce/reference/manual.scrbl b/collects/unstable/cce/reference/manual.scrbl index 3d6ea7ae89..49eb72e379 100644 --- a/collects/unstable/cce/reference/manual.scrbl +++ b/collects/unstable/cce/reference/manual.scrbl @@ -12,7 +12,6 @@ @include-section["values.scrbl"] -@include-section["text.scrbl"] @include-section["regexp.scrbl"] @include-section["web.scrbl"] diff --git a/collects/unstable/cce/reference/web.scrbl b/collects/unstable/cce/reference/web.scrbl index 1481a9f8d4..d4f5eaeb2d 100644 --- a/collects/unstable/cce/reference/web.scrbl +++ b/collects/unstable/cce/reference/web.scrbl @@ -29,7 +29,8 @@ described by the following grammar: [value text] ] -Here, @scheme[text] is any of the datatypes described in @secref["cce-text"]. +Here, @scheme[text] is any of the datatypes described in +@secref["unstable-text"]. } @defthing[xexpr/c flat-contract?]{ diff --git a/collects/unstable/cce/syntax.ss b/collects/unstable/cce/syntax.ss index 68bfeb9812..5c9b80123a 100644 --- a/collects/unstable/cce/syntax.ss +++ b/collects/unstable/cce/syntax.ss @@ -8,14 +8,14 @@ syntax/kerncase setup/main-collects planet/planet-archives + unstable/text (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") + "contract.ss") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/collects/unstable/cce/test/test-main.ss b/collects/unstable/cce/test/test-main.ss index d890a7e7b3..259afccb4c 100644 --- a/collects/unstable/cce/test/test-main.ss +++ b/collects/unstable/cce/test/test-main.ss @@ -18,7 +18,6 @@ "test-scribble.ss" "test-set.ss" "test-syntax.ss" - "test-text.ss" "test-values.ss" "test-web.ss") @@ -41,6 +40,5 @@ scribble-suite set-suite syntax-suite - text-suite values-suite web-suite)) diff --git a/collects/unstable/cce/test/test-text.ss b/collects/unstable/cce/test/test-text.ss deleted file mode 100644 index 609ff624ec..0000000000 --- a/collects/unstable/cce/test/test-text.ss +++ /dev/null @@ -1,136 +0,0 @@ -#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/web.ss b/collects/unstable/cce/web.ss index 54e6311568..6b23f05a93 100644 --- a/collects/unstable/cce/web.ss +++ b/collects/unstable/cce/web.ss @@ -1,8 +1,8 @@ #lang scheme (require xml unstable/function - "define.ss" - "text.ss") + unstable/text + "define.ss") ;; css/c : FlatContract ;; Recognizes representations of Cascading Style Sheets. diff --git a/collects/unstable/cce/reference/text.scrbl b/collects/unstable/scribblings/text.scrbl similarity index 92% rename from collects/unstable/cce/reference/text.scrbl rename to collects/unstable/scribblings/text.scrbl index 11f18d613a..14ed4c2642 100644 --- a/collects/unstable/cce/reference/text.scrbl +++ b/collects/unstable/scribblings/text.scrbl @@ -1,13 +1,11 @@ -#lang scribble/doc -@(require scribble/manual - scribble/eval - "../scribble.ss" - "eval.ss") -@(require (for-label scheme unstable/cce/text)) +#lang scribble/manual +@(require scribble/eval "utils.rkt" (for-label racket unstable/text)) -@title[#:style 'quiet #:tag "cce-text"]{Text Representations} +@title[#:tag "unstable-text"]{Text Representations} -@defmodule[unstable/cce/text] +@defmodule[unstable/text] + +@unstable[@author+email["Carl Eastlund" "cce@racket-lang.org"]] This module provides tools for manipulating and converting textual data. @@ -22,7 +20,7 @@ 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) +#:eval (eval/require 'unstable/text) (text? "text") (text? #"text") (text? 'text) @@ -45,7 +43,7 @@ symbols, and keywords, as well as syntax objects containing them. These predicates recognize specific text types stored in syntax objects. @defexamples[ -#:eval (evaluator 'unstable/cce/text) +#:eval (eval/require 'unstable/text) (string-literal? #'"literal") (string-literal? "not literal") (bytes-literal? #'#"literal") @@ -82,7 +80,7 @@ These functions convert text values to specific types. They concatenate each and back of the result and @scheme[between] between each argument. @defexamples[ -#:eval (evaluator 'unstable/cce/text) +#:eval (eval/require 'unstable/text) (text->string #"concat" #'enate) (text->bytes #:between "-" 'concat #'#:enate) (text->symbol #:before "(" #:after ")" '#:concat #'"enate") @@ -124,7 +122,7 @@ syntax object properties from the @scheme[stx] argument. They concatenate each and back of the result and @scheme[between] between each argument. @defexamples[ -#:eval (evaluator 'unstable/cce/text) +#:eval (eval/require 'unstable/text) (text->string-literal #"concat" #'enate) (text->bytes-literal #:between "-" 'concat #'#:enate) (text->identifier #:before "(" #:after ")" @@ -159,7 +157,7 @@ equivalent to: ] @defexamples[ -#:eval (evaluator 'unstable/cce/text) +#:eval (eval/require 'unstable/text) (text=? #"x" #'y) (text