this might work
parent
55d7528084
commit
144536fb27
@ -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"))
|
@ -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
|
@ -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?)])
|
@ -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?"))
|
||||
"<root><script>3 > 2</script>Why is 3 > 2?</root>")
|
||||
[(_ 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?"))
|
||||
"<root><script><![CDATA[3 > 2]]></script>Why is 3 > 2?</root>"))
|
@ -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?"))
|
||||
"<root><script><![CDATA[3 > 2]]></script>Why is 3 > 2?</root>")
|
Loading…
Reference in New Issue