diff --git a/info.rkt b/info.rkt index 70f980f..5ad8e4c 100644 --- a/info.rkt +++ b/info.rkt @@ -1,4 +1,6 @@ #lang info (define collection 'multi) -(define deps '("base" "sugar")) -(define build-deps '("scribble-lib" "racket-doc")) +(define deps '("base" "sugar" "typed-racket-lib" + "typed-racket-more" + "rackunit-lib")) +(define build-deps '("scribble-lib" "racket-doc" "typed-racket-doc")) \ No newline at end of file diff --git a/txexpr/core-predicates.rkt b/txexpr/core-predicates.rkt index aa49d61..9830c90 100644 --- a/txexpr/core-predicates.rkt +++ b/txexpr/core-predicates.rkt @@ -1,3 +1,54 @@ #lang racket/base +(require sugar/define xml racket/match) +(provide (all-defined-out) valid-char? cdata? cdata xexpr->string xexpr?) + +(define (txexpr-short? x) + (match x + [(list (? symbol? name) (? xexpr?) ...) #t] + [else #f])) + +(define (txexpr? x) + (or (txexpr-short? x) + (match x + [(list (? symbol?) (list (list (? symbol?) (? string?)) ...) (? xexpr?) ...) #t] + [else #f]))) + +(define (txexpr-tag? x) + (symbol? x)) + +(define (txexpr-attr? x) + (match x + [(list (? symbol?) (? string?)) #t] + [else #f])) + + +(define (txexpr-attrs? x) + (and (list? x) (andmap txexpr-attr? x))) + +(define (txexpr-element? x) + (xexpr? x)) + +(define (txexpr-elements? x) + (and (list? x) (andmap txexpr-element? x))) + +(define (txexpr-attr-key? x) + (symbol? x)) + +(define (can-be-txexpr-attr-key? x) + (or (symbol? x) (string? x))) + +(define (txexpr-attr-value? x) + (string? x)) + +(define (txexpr-attr-values? x) + (and (list? x) (andmap txexpr-attr-value? x))) + +(define (can-be-txexpr-attr-value? x) + (or (symbol? x) (string? x))) + +(define (can-be-txexpr-attrs? x) + (ormap (λ(test) (test x)) (list txexpr-attr? txexpr-attrs? can-be-txexpr-attr-key? can-be-txexpr-attr-value?))) + +(define (list-of-can-be-txexpr-attrs? xs) + (and (list? xs) (andmap can-be-txexpr-attrs? xs))) -;; zilch \ No newline at end of file diff --git a/txexpr/main.rkt b/txexpr/main.rkt index 737559e..2c06c40 100644 --- a/txexpr/main.rkt +++ b/txexpr/main.rkt @@ -1,15 +1,42 @@ #lang racket/base -(require sugar/include sugar/define xml) +(require sugar/define) -(define+provide+safe (txexpr? x) - (any/c . -> . boolean?) - (with-handlers ([exn:fail? (λ(exn) #f)]) - (and (validate-txexpr x) #t))) +(require-via-wormhole "../typed/txexpr/main.rkt") -(define+provide+safe (txexpr-attr? x) - (any/c . -> . boolean?) - (match x - [(list (? symbol?) (? string?)) #t] - [else #f])) - -(include-without-lang-line "../typed/txexpr/main.rkt") +(provide+safe + [xexpr? predicate/c] + [txexpr? predicate/c] + [txexpr-short? predicate/c] + [txexpr-tag? predicate/c] + [txexpr-attr? predicate/c] + [txexpr-attrs? predicate/c] + [txexpr-element? predicate/c] + [txexpr-elements? predicate/c] + [validate-txexpr (any/c . -> . txexpr?)] + [make-txexpr ((symbol?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)] + [txexpr->values (txexpr? . -> . (values symbol? txexpr-attrs? txexpr-elements?))] + [txexpr->list (txexpr? . -> . list?)] + [get-tag (txexpr? . -> . txexpr-tag?)] + [get-attrs (txexpr? . -> . txexpr-attrs?)] + [get-elements (txexpr? . -> . txexpr-elements?)] + [txexpr-attr-key? predicate/c] + [txexpr-attr-value? predicate/c] + [can-be-txexpr-attr-key? predicate/c] + [can-be-txexpr-attr-value? predicate/c] + [->txexpr-attr-key (can-be-txexpr-attr-key? . -> . txexpr-attr-key?)] + [->txexpr-attr-value (can-be-txexpr-attr-value? . -> . txexpr-attr-value?)] + [can-be-txexpr-attrs? predicate/c] + [list-of-can-be-txexpr-attrs? predicate/c] + [attrs->hash (() #:rest (listof can-be-txexpr-attrs?) . ->* . hash?)] + [hash->attrs (hash? . -> . txexpr-attrs?)] + [attr-ref (txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-value?)] + [attr-ref* (txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-values?)] + [attrs-have-key? ((or/c txexpr-attrs? txexpr?) can-be-txexpr-attr-key? . -> . boolean?)] + [attrs-equal? ((or/c txexpr-attrs? txexpr?) (or/c txexpr-attrs? txexpr?) . -> . boolean?)] + [attr-set (txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?)] + [merge-attrs (() #:rest list-of-can-be-txexpr-attrs? . ->* . txexpr-attrs?)] + [remove-attrs (txexpr? . -> . txexpr?)] + [map-elements/exclude (procedure? txexpr? procedure? . -> . txexpr?)] + [map-elements (procedure? txexpr? . -> . txexpr?)] + [splitf-txexpr ((txexpr? procedure?) (procedure?) . ->* . (values txexpr? txexpr-elements?))] + [xexpr->html (xexpr? . -> . string?)]) \ No newline at end of file diff --git a/txexpr/scribblings/txexpr.scrbl b/txexpr/scribblings/txexpr.scrbl index d866f22..b31dce2 100644 --- a/txexpr/scribblings/txexpr.scrbl +++ b/txexpr/scribblings/txexpr.scrbl @@ -1,6 +1,6 @@ #lang scribble/manual -@(require scribble/eval (for-label racket txexpr xml)) +@(require scribble/eval (for-label racket txexpr xml (only-in typed/racket require/typed))) @(define my-eval (make-base-eval)) @(my-eval `(require txexpr xml)) @@ -10,7 +10,7 @@ @author[(author+email "Matthew Butterick" "mb@mbtype.com")] -@defmodule[#:multi (txexpr (submod txexpr safe))] +@defmodule[#:multi (txexpr (submod txexpr safe) typed/txexpr)] A set of small but handy functions for improving the readability and reliability of programs that operate on tagged X-expressions (for short, @italic{txexpr}s). @@ -24,10 +24,14 @@ After that, you can update the package from the command line: @section{Importing the module} -The module operates in two modes: fast and safe. Fast mode is the default, which you get by importing the module in the usual way: @code{(require txexpr)}. +The module can be invoked three ways: fast, safe, and typed. + +Fast mode is the default, which you get by importing the module in the usual way: @code{(require txexpr)}. Safe mode enables the function contracts documented below. Use safe mode by importing the module as @code{(require (submod txexpr safe))}. +The typed version is invoked as @code{(require typed/txexpr)}. The typed version is implemented ``natively'' in the sense that it is compiled separately with type annotations. It is not a @racket[require/typed] wrapper around the untyped code. This avoids the contract barrier that is otherwise automatically imposed between typed and untyped code. + @section{What’s a txexpr?} diff --git a/txexpr/tests.rkt b/txexpr/tests.rkt index 2e10cb3..f320836 100644 --- a/txexpr/tests.rkt +++ b/txexpr/tests.rkt @@ -1,158 +1,192 @@ #lang racket/base -(require (for-syntax racket/base)) -(require (submod "main.rkt" safe) rackunit) +(require (for-syntax racket/base racket/syntax)) -(define-syntax (values->list stx) +(define-syntax (eval-as-untyped stx) (syntax-case stx () - [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) - -(check-true (txexpr-tag?'foo)) -(check-false (txexpr-tag? "foo")) -(check-false (txexpr-tag? 3)) - -(check-true (txexpr-attr? '(key "value"))) -(check-false (txexpr-attr? '(key "value" "another"))) -(check-false (txexpr-attr? '(key 0 "value"))) - -(check-true (txexpr-attrs? '())) -(check-true (txexpr-attrs? '((key "value")))) -(check-true (txexpr-attrs? '((key "value") (foo "bar")))) -(check-false (txexpr-attrs? '((key "value") "foo" "bar"))) ; content, not attr -(check-false (txexpr-attrs? '(key "value"))) ; not a nested list -(check-false (txexpr-attrs? '(("key" "value")))) ; two strings -(check-false (txexpr-attrs? '((key value)))) ; two symbols - -(check-true (txexpr-element? "string")) -(check-true (txexpr-element? 'amp)) -(check-true (txexpr-element? '(p "string"))) -(check-true (txexpr-element? 65)) ;; a valid-char -(check-false (txexpr-element? 0)) ;; not a valid-char - -(check-true (txexpr-elements? '("p" "foo" "123"))) -(check-true (txexpr-elements? '("p" "foo" 123))) ; includes number -(check-true (txexpr-elements? '(p "foo" "123"))) ; includes symbol -(check-false (txexpr-elements? "foo")) ; not a list -(check-false (txexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr -(check-false (txexpr-elements? '("foo" "bar" ((key "value"))))) ; malformed - -(check-true (txexpr? '(p))) -(check-true (txexpr? '(p "foo" "bar"))) -(check-true (txexpr? '(p ((key "value")) "foo" "bar"))) -(check-true (txexpr? '(p 123))) ; content is a number -(check-false (txexpr? "foo")) ; not a list with symbol -(check-false (txexpr? '(p "foo" "bar" ((key "value"))))) ; malformed -(check-false (txexpr? '("p" "foo" "bar"))) ; no name - -(check-equal? (make-txexpr 'p) '(p)) -(check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value")))) -(check-equal? (make-txexpr 'p null '("foo" "bar")) '(p "foo" "bar")) -(check-equal? (make-txexpr 'p '((key "value")) (list "foo" "bar")) - '(p ((key "value")) "foo" "bar")) - -(check-equal? (values->list (txexpr->values '(p))) - (values->list (values 'p null null))) -(check-equal? (values->list (txexpr->values '(p "foo"))) - (values->list (values 'p null '("foo")))) -(check-equal? (values->list (txexpr->values '(p ((key "value"))))) - (values->list (values 'p '((key "value")) null))) -(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) - (values->list (values 'p '((key "value")) '("foo")))) - -(check-equal? (values->list (txexpr->values '(p))) - (txexpr->list '(p))) -(check-equal? (values->list (txexpr->values '(p "foo"))) - (txexpr->list '(p "foo"))) -(check-equal? (values->list (txexpr->values '(p ((key "value"))))) - (txexpr->list '(p ((key "value"))))) -(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) - (txexpr->list '(p ((key "value")) "foo"))) - -(check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p) -(check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value"))) -(check-equal? (get-elements '(p ((key "value"))"foo" "bar" (em "square"))) - '("foo" "bar" (em "square"))) - - -(check-equal? (->txexpr-attr-key "foo") 'foo) -(check-equal? (->txexpr-attr-key 'foo) 'foo) - -(check-equal? (->txexpr-attr-value "foo") "foo") -(check-equal? (->txexpr-attr-value 'foo) "foo") - -(check-equal? (attrs->hash '((foo "bar"))) '#hash((foo . "bar"))) -(check-equal? (attrs->hash '((foo "bar")) '(foo "fraw")) '#hash((foo . "fraw"))) -(check-equal? (attrs->hash '((foo "bar")) '(foo "fraw") 'foo "dog") '#hash((foo . "dog"))) - -(check-equal? (hash->attrs '#hash((foo . "bar")(hee . "haw"))) '((foo "bar")(hee "haw"))) - -(check-equal? (attr-ref '(p ((foo "bar"))) 'foo) "bar") -(check-equal? (attr-set '(p ((foo "bar"))) 'foo "fraw") '(p ((foo "fraw")))) - -(check-true (attrs-have-key? '(p ((color "red")(shape "circle"))) 'color)) -(check-true (attrs-have-key? '(p ((color "red")(shape "circle"))) "color")) -(check-false (attrs-have-key? '((color "red")(shape "circle")) 'nonexistent)) - -(check-true (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((color "red")(shape "circle"))))) - -(check-false (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((color "blue")(shape "circle"))))) - -(check-true (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((shape "circle")(color "red"))))) - -(check-false (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((color "red"))))) - -(check-true (attrs-equal? '((color "red")(shape "circle")) - '((color "red")(shape "circle")))) - -(check-false (attrs-equal? '((color "red")(shape "circle")) - '((color "blue")(shape "circle")))) - -(check-true (attrs-equal? '((color "red")(shape "circle")) - '((shape "circle")(color "red")))) - -(check-false (attrs-equal? '((color "red")(shape "circle")) - '((color "red")))) - - - -(check-equal? (merge-attrs 'foo "bar") '((foo "bar"))) -(check-equal? (merge-attrs '(foo "bar")) '((foo "bar"))) -(check-equal? (merge-attrs '((foo "bar"))) '((foo "bar"))) -(check-equal? (merge-attrs "foo" 'bar) '((foo "bar"))) -(check-equal? (merge-attrs "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar"))) -(check-equal? (merge-attrs (merge-attrs "foo" "bar" "goo" "gar") "hee" "haw") - '((foo "bar")(goo "gar")(hee "haw"))) -(check-equal? (merge-attrs '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar"))) - - -(check-equal? (remove-attrs '(p ((foo "bar")) "hi")) '(p "hi")) -(check-equal? (remove-attrs '(p ((foo "bar")) "hi" (p ((foo "bar")) "hi"))) '(p "hi" (p "hi"))) - - -(check-equal? (map-elements (λ(x) (if (string? x) "boing" x)) - '(p "foo" "bar" (em "square"))) - '(p "boing" "boing" (em "boing"))) - - -(check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") - (em ((foo "zam")) "goodnight" "moon")) 'foo) '("bar" "zam" "zam")) - -(check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") - (em ((foo "zam")) "goodnight" "moon")) 'nonexistent-key) '()) - - -(define split-this-tx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2") - (em "goodnight" "moon" (meta "foo3" "bar3")))) -(define split-predicate (λ(x) (and (txexpr? x) (equal? 'meta (car x))))) -(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate)) list) - (list '(root "hello" "world" (em "goodnight" "moon")) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))) - -(define split-proc (λ(x) '(div "foo"))) -(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate split-proc)) list) - (list '(root (div "foo") "hello" "world" (div "foo") (em "goodnight" "moon" (div "foo"))) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))) - -(check-equal? (xexpr->html '(root (script "3 > 2") "Why is 3 > 2?")) - "Why is 3 > 2?") \ No newline at end of file + [(_ exprs ...) + (with-syntax ([sym (generate-temporary)]) + #'(begin + (module sym racket + (require rackunit (submod txexpr safe)) + exprs ...) + (require 'sym)))])) + +(define-syntax (eval-as-typed stx) + (syntax-case stx () + [(_ exprs ...) + (with-syntax ([sym (generate-temporary)]) + #'(begin + (module sym typed/racket + (require typed/rackunit typed/txexpr) + exprs ...) + (require 'sym)))])) + +(define-syntax-rule (eval-as-typed-and-untyped exprs ...) + (begin + (eval-as-typed exprs ...) + (eval-as-untyped exprs ...))) + + +(eval-as-typed-and-untyped + (define-syntax (values->list stx) + (syntax-case stx () + [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) + (check-true (txexpr-tag? 'foo)) + (check-false (txexpr-tag? "foo")) + (check-false (txexpr-tag? 3)) + + (check-true (txexpr-attr? '(key "value"))) + (check-false (txexpr-attr? '(key "value" "another"))) + (check-false (txexpr-attr? '(key 0 "value"))) + + (check-true (txexpr-attrs? '())) + (check-true (txexpr-attrs? '((key "value")))) + (check-true (txexpr-attrs? '((key "value") (foo "bar")))) + (check-false (txexpr-attrs? '((key "value") "foo" "bar"))) ; content, not attr + (check-false (txexpr-attrs? '(key "value"))) ; not a nested list + (check-false (txexpr-attrs? '(("key" "value")))) ; two strings + (check-false (txexpr-attrs? '((key value)))) ; two symbols + + (check-true (txexpr-element? "string")) + (check-true (txexpr-element? 'amp)) + (check-true (txexpr-element? '(p "string"))) + (check-true (txexpr-element? 65)) ;; a valid-char + (check-false (txexpr-element? 0)) ;; not a valid-char + + (check-true (txexpr-elements? '("p" "foo" "123"))) + (check-true (txexpr-elements? '("p" "foo" 123))) ; includes number + (check-true (txexpr-elements? '(p "foo" "123"))) ; includes symbol + (check-false (txexpr-elements? "foo")) ; not a list + (check-false (txexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr + (check-false (txexpr-elements? '("foo" "bar" ((key "value"))))) ; malformed + + (check-true (txexpr? '(p))) + (check-true (txexpr? '(p "foo" "bar"))) + (check-true (txexpr? '(p ((key "value")) "foo" "bar"))) + (check-true (txexpr? '(p 123))) ; content is a number + (check-false (txexpr? "foo")) ; not a list with symbol + (check-false (txexpr? '(p "foo" "bar" ((key "value"))))) ; malformed + (check-false (txexpr? '("p" "foo" "bar"))) ; no name + + (check-not-exn (λ _ (validate-txexpr '(p)))) + (check-not-exn (λ _ (validate-txexpr '(p "foo" "bar")))) + (check-not-exn (λ _ (validate-txexpr '(p ((key "value")) "foo" "bar")))) + (check-not-exn (λ _ (validate-txexpr '(p 123)))) ; content is a valid-char + ;(check-exn (λ _ (validate-txexpr "foo"))) ; not a list with symbol + ;(check-exn (λ _ (validate-txexpr '(p "foo" "bar" ((key "value")))))) ; malformed + ;(check-exn (λ _ (validate-txexpr '("p" "foo" "bar")))) ; no name + + + (check-equal? (make-txexpr 'p) '(p)) + (check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value")))) + (check-equal? (make-txexpr 'p null '("foo" "bar")) '(p "foo" "bar")) + (check-equal? (make-txexpr 'p '((key "value")) (list "foo" "bar")) + '(p ((key "value")) "foo" "bar")) + + (check-equal? (values->list (txexpr->values '(p))) + (values->list (values 'p null null))) + (check-equal? (values->list (txexpr->values '(p "foo"))) + (values->list (values 'p null '("foo")))) + (check-equal? (values->list (txexpr->values '(p ((key "value"))))) + (values->list (values 'p '((key "value")) null))) + (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) + (values->list (values 'p '((key "value")) '("foo")))) + + (check-equal? (values->list (txexpr->values '(p))) + (txexpr->list '(p))) + (check-equal? (values->list (txexpr->values '(p "foo"))) + (txexpr->list '(p "foo"))) + (check-equal? (values->list (txexpr->values '(p ((key "value"))))) + (txexpr->list '(p ((key "value"))))) + (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) + (txexpr->list '(p ((key "value")) "foo"))) + + (check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p) + (check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value"))) + (check-equal? (get-elements '(p ((key "value"))"foo" "bar" (em "square"))) + '("foo" "bar" (em "square"))) + + + (check-equal? (->txexpr-attr-key "foo") 'foo) + (check-equal? (->txexpr-attr-key 'foo) 'foo) + + (check-equal? (->txexpr-attr-value "foo") "foo") + (check-equal? (->txexpr-attr-value 'foo) "foo") + + (check-equal? (attrs->hash '((foo "bar"))) '#hash((foo . "bar"))) + (check-equal? (attrs->hash '((foo "bar")) '(foo "fraw")) '#hash((foo . "fraw"))) + (check-equal? (attrs->hash '((foo "bar")) '(foo "fraw") 'foo "dog") '#hash((foo . "dog"))) + + (check-equal? (hash->attrs '#hash((foo . "bar")(hee . "haw"))) '((foo "bar")(hee "haw"))) + + (check-equal? (attr-ref '(p ((foo "bar"))) 'foo) "bar") + (check-equal? (attr-set '(p ((foo "bar"))) 'foo "fraw") '(p ((foo "fraw")))) + + (check-true (attrs-have-key? '(p ((color "red")(shape "circle"))) 'color)) + (check-true (attrs-have-key? '(p ((color "red")(shape "circle"))) "color")) + (check-false (attrs-have-key? '((color "red")(shape "circle")) 'nonexistent)) + + (check-true (attrs-equal? '(p ((color "red")(shape "circle"))) + '(foo ((color "red")(shape "circle"))))) + + (check-false (attrs-equal? '(p ((color "red")(shape "circle"))) + '(foo ((color "blue")(shape "circle"))))) + + (check-true (attrs-equal? '(p ((color "red")(shape "circle"))) + '(foo ((shape "circle")(color "red"))))) + + (check-false (attrs-equal? '(p ((color "red")(shape "circle"))) + '(foo ((color "red"))))) + + (check-true (attrs-equal? '((color "red")(shape "circle")) + '((color "red")(shape "circle")))) + + (check-false (attrs-equal? '((color "red")(shape "circle")) + '((color "blue")(shape "circle")))) + + (check-true (attrs-equal? '((color "red")(shape "circle")) + '((shape "circle")(color "red")))) + + (check-false (attrs-equal? '((color "red")(shape "circle")) + '((color "red")))) + + + + (check-equal? (merge-attrs 'foo "bar") '((foo "bar"))) + (check-equal? (merge-attrs '(foo "bar")) '((foo "bar"))) + (check-equal? (merge-attrs '((foo "bar"))) '((foo "bar"))) + (check-equal? (merge-attrs "foo" 'bar) '((foo "bar"))) + (check-equal? (merge-attrs "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar"))) + (check-equal? (merge-attrs (merge-attrs "foo" "bar" "goo" "gar") "hee" "haw") + '((foo "bar")(goo "gar")(hee "haw"))) + (check-equal? (merge-attrs '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar"))) + + + (check-equal? (remove-attrs '(p ((foo "bar")) "hi")) '(p "hi")) + (check-equal? (remove-attrs '(p ((foo "bar")) "hi" (p ((foo "bar")) "hi"))) '(p "hi" (p "hi"))) + + + (check-equal? (map-elements (λ(x) (if (string? x) "boing" x)) + '(p "foo" "bar" (em "square"))) + '(p "boing" "boing" (em "boing"))) + + + (check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") + (em ((foo "zam")) "goodnight" "moon")) 'foo) '("bar" "zam" "zam")) + + (check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") + (em ((foo "zam")) "goodnight" "moon")) 'nonexistent-key) '()) + + + (define split-this-tx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2") + (em "goodnight" "moon" (meta "foo3" "bar3")))) + (define split-predicate (λ(x) (and (txexpr? x) (equal? 'meta (car x))))) + (check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate)) list) + (list '(root "hello" "world" (em "goodnight" "moon")) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))) + + (define split-proc (λ(x) '(div "foo"))) + (check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate split-proc)) list) + (list '(root (div "foo") "hello" "world" (div "foo") (em "goodnight" "moon" (div "foo"))) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))) + + (check-equal? (xexpr->html '(root (script "3 > 2") "Why is 3 > 2?")) + "Why is 3 > 2?")) \ No newline at end of file diff --git a/typed/txexpr/core-predicates.rkt b/typed/txexpr/core-predicates.rkt index 593c6f6..847e4dc 100644 --- a/typed/txexpr/core-predicates.rkt +++ b/typed/txexpr/core-predicates.rkt @@ -26,8 +26,6 @@ (provide (all-from-out xml) cdata? xexpr->string) - - (define-type Valid-Char Natural) ;; overinclusive but that's as good as it gets (define-type Txexpr-Tag Symbol) (define-type Txexpr-Attr-Key Symbol) diff --git a/typed/txexpr/main.rkt b/typed/txexpr/main.rkt index 5c74062..45389a2 100644 --- a/typed/txexpr/main.rkt +++ b/typed/txexpr/main.rkt @@ -2,7 +2,7 @@ (require (for-syntax typed/racket/base) typed/sugar/define) (require racket/match racket/string racket/list racket/bool "core-predicates.rkt") (provide (all-defined-out) (all-from-out "core-predicates.rkt")) - +(require typed/sugar/debug) (define/typed (validate-txexpr-attrs x #:context [txexpr-context #f]) ((Txexpr-Attrs) (#:context Any) . ->* . Txexpr-Attrs) (define/typed (make-reason) @@ -14,7 +14,7 @@ "are not valid attributes" "is not in the form '(symbol \"string\")"))))) (cond - [(and (list? x) (> 0 (length x)) (andmap txexpr-attr? x)) x] + [(and (list? x) (> (length x) 0) (andmap txexpr-attr? x)) x] [else (error (string-append "validate-txexpr-attrs: " (if txexpr-context (format "in ~v, " txexpr-context) "") (format "~v is not a valid list of attributes ~a" x (make-reason))))])) diff --git a/typed/txexpr/tests.rkt b/typed/txexpr/tests.rkt deleted file mode 100644 index 55a0b28..0000000 --- a/typed/txexpr/tests.rkt +++ /dev/null @@ -1,159 +0,0 @@ -#lang typed/racket/base -(require (for-syntax racket/base)) -(require "main.rkt" typed/rackunit) - -(define-syntax (values->list stx) - (syntax-case stx () - [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) - -(check-true (txexpr-tag?'foo)) -(check-false (txexpr-tag? "foo")) -(check-false (txexpr-tag? 3)) - -(check-true (txexpr-attr? '(key "value"))) -(check-false (txexpr-attr? '(key "value" "another"))) -(check-false (txexpr-attr? '(key 0 "value"))) - -(check-true (txexpr-attrs? '())) -(check-true (txexpr-attrs? '((key "value")))) -(check-true (txexpr-attrs? '((key "value") (foo "bar")))) -(check-false (txexpr-attrs? '((key "value") "foo" "bar"))) ; content, not attr -(check-false (txexpr-attrs? '(key "value"))) ; not a nested list -(check-false (txexpr-attrs? '(("key" "value")))) ; two strings -(check-false (txexpr-attrs? '((key value)))) ; two symbols - -(check-true (txexpr-element? "string")) -(check-true (txexpr-element? 'amp)) -(check-true (txexpr-element? '(p "string"))) -(check-true (txexpr-element? 65)) ;; a valid-char -(check-false (txexpr-element? 0)) ;; not a valid-char - -(check-true (txexpr-elements? '("p" "foo" "123"))) -(check-true (txexpr-elements? '("p" "foo" 123))) ; includes number -(check-true (txexpr-elements? '(p "foo" "123"))) ; includes symbol -(check-false (txexpr-elements? "foo")) ; not a list -(check-false (txexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr -(check-false (txexpr-elements? '("foo" "bar" ((key "value"))))) ; malformed - -(check-true (txexpr? '(p))) -(check-true (txexpr? '(p "foo" "bar"))) -(check-true (txexpr? '(p ((key "value")) "foo" "bar"))) -(check-true (txexpr? '(p 123))) ; content is a number -(check-false (txexpr? "foo")) ; not a list with symbol -(check-false (txexpr? '(p "foo" "bar" ((key "value"))))) ; malformed -(check-false (txexpr? '("p" "foo" "bar"))) ; no name - -(check-equal? (make-txexpr 'p) '(p)) -(check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value")))) -(check-equal? (make-txexpr 'p null '("foo" "bar")) '(p "foo" "bar")) -(check-equal? (make-txexpr 'p '((key "value")) (list "foo" "bar")) - '(p ((key "value")) "foo" "bar")) - -(check-equal? (values->list (txexpr->values '(p))) - (values->list (values 'p null null))) -(check-equal? (values->list (txexpr->values '(p "foo"))) - (values->list (values 'p null '("foo")))) -(check-equal? (values->list (txexpr->values '(p ((key "value"))))) - (values->list (values 'p '((key "value")) null))) -(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) - (values->list (values 'p '((key "value")) '("foo")))) - -(check-equal? (values->list (txexpr->values '(p))) - (txexpr->list '(p))) -(check-equal? (values->list (txexpr->values '(p "foo"))) - (txexpr->list '(p "foo"))) -(check-equal? (values->list (txexpr->values '(p ((key "value"))))) - (txexpr->list '(p ((key "value"))))) -(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) - (txexpr->list '(p ((key "value")) "foo"))) - -(check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p) -(check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value"))) -(check-equal? (get-elements '(p ((key "value"))"foo" "bar" (em "square"))) - '("foo" "bar" (em "square"))) - - -(check-equal? (->txexpr-attr-key "foo") 'foo) -(check-equal? (->txexpr-attr-key 'foo) 'foo) - -(check-equal? (->txexpr-attr-value "foo") "foo") -(check-equal? (->txexpr-attr-value 'foo) "foo") - -(check-equal? (attrs->hash '((foo "bar"))) '#hash((foo . "bar"))) -(check-equal? (attrs->hash '((foo "bar")) '(foo "fraw")) '#hash((foo . "fraw"))) -(check-equal? (attrs->hash '((foo "bar")) '(foo "fraw") 'foo "dog") '#hash((foo . "dog"))) - -(check-equal? (hash->attrs '#hash((foo . "bar")(hee . "haw"))) '((foo "bar")(hee "haw"))) - -(check-equal? (attr-ref '(p ((foo "bar"))) 'foo) "bar") -(check-equal? (attr-set '(p ((foo "bar"))) 'foo "fraw") '(p ((foo "fraw")))) - -(check-true (attrs-have-key? '(p ((color "red")(shape "circle"))) 'color)) -(check-true (attrs-have-key? '(p ((color "red")(shape "circle"))) "color")) -(check-false (attrs-have-key? '((color "red")(shape "circle")) 'nonexistent)) - -(check-true (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((color "red")(shape "circle"))))) - -(check-false (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((color "blue")(shape "circle"))))) - -(check-true (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((shape "circle")(color "red"))))) - -(check-false (attrs-equal? '(p ((color "red")(shape "circle"))) - '(foo ((color "red"))))) - -(check-true (attrs-equal? '((color "red")(shape "circle")) - '((color "red")(shape "circle")))) - -(check-false (attrs-equal? '((color "red")(shape "circle")) - '((color "blue")(shape "circle")))) - -(check-true (attrs-equal? '((color "red")(shape "circle")) - '((shape "circle")(color "red")))) - -(check-false (attrs-equal? '((color "red")(shape "circle")) - '((color "red")))) - - - -(check-equal? (merge-attrs 'foo "bar") '((foo "bar"))) -(check-equal? (merge-attrs '(foo "bar")) '((foo "bar"))) -(check-equal? (merge-attrs '((foo "bar"))) '((foo "bar"))) -(check-equal? (merge-attrs "foo" 'bar) '((foo "bar"))) -(check-equal? (merge-attrs "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar"))) -(check-equal? (merge-attrs (merge-attrs "foo" "bar" "goo" "gar") "hee" "haw") - '((foo "bar")(goo "gar")(hee "haw"))) -(check-equal? (merge-attrs '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar"))) - - - -(check-equal? (remove-attrs '(p ((foo "bar")) "hi")) '(p "hi")) -(check-equal? (remove-attrs '(p ((foo "bar")) "hi" (p ((foo "bar")) "hi"))) '(p "hi" (p "hi"))) - - -(check-equal? (map-elements (λ(x) (if (string? x) "boing" x)) - '(p "foo" "bar" (em "square"))) - '(p "boing" "boing" (em "boing"))) - - -(check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") - (em ((foo "zam")) "goodnight" "moon")) 'foo) '("bar" "zam" "zam")) - -(check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") - (em ((foo "zam")) "goodnight" "moon")) 'nonexistent-key) '()) - - -(define split-this-tx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2") - (em "goodnight" "moon" (meta "foo3" "bar3")))) -(define split-predicate (λ(x) (and (txexpr? x) (equal? 'meta (car x))))) -(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate)) list) - (list '(root "hello" "world" (em "goodnight" "moon")) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))) - -(define split-proc (λ(x) '(div "foo"))) -(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate split-proc)) list) - (list '(root (div "foo") "hello" "world" (div "foo") (em "goodnight" "moon" (div "foo"))) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))) - -(check-equal? (xexpr->html '(root (script "3 > 2") "Why is 3 > 2?")) - "Why is 3 > 2?") \ No newline at end of file