mbutterick
/
txexpr
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

this might work

Browse Source
typed-work
Matthew Butterick 10 years ago
parent 55d7528084
commit 144536fb27
8 changed files with 293 additions and 336 deletions
Show Stats Download Patch File Download Diff File

6
info.rkt
Unescape Escape View File

@ -1,4 +1,6 @@
#lang info #lang info
(define collection 'multi) (define collection 'multi)
(define deps '("base" "sugar")) (define deps '("base" "sugar" "typed-racket-lib"
(define build-deps '("scribble-lib" "racket-doc")) "typed-racket-more"
"rackunit-lib"))
(define build-deps '("scribble-lib" "racket-doc" "typed-racket-doc"))

53
txexpr/core-predicates.rkt
Unescape Escape View File

@ -1,3 +1,54 @@
#lang racket/base #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

51
txexpr/main.rkt
Unescape Escape View File

@ -1,15 +1,42 @@
#lang racket/base #lang racket/base
(require sugar/include sugar/define xml) (require sugar/define)
(define+provide+safe (txexpr? x) (require-via-wormhole "../typed/txexpr/main.rkt")
(any/c . -> . boolean?)
(with-handlers ([exn:fail? (λ(exn) #f)])
(and (validate-txexpr x) #t)))
(define+provide+safe (txexpr-attr? x) (provide+safe
(any/c . -> . boolean?) [xexpr? predicate/c]
(match x [txexpr? predicate/c]
[(list (? symbol?) (? string?)) #t] [txexpr-short? predicate/c]
[else #f])) [txexpr-tag? predicate/c]
[txexpr-attr? predicate/c]
(include-without-lang-line "../typed/txexpr/main.rkt") [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?)])

10
txexpr/scribblings/txexpr.scrbl
Unescape Escape View File

@ -1,6 +1,6 @@
#lang scribble/manual #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)) @(define my-eval (make-base-eval))
@(my-eval `(require txexpr xml)) @(my-eval `(require txexpr xml))
@ -10,7 +10,7 @@
@author[(author+email "Matthew Butterick" "mb@mbtype.com")] @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). 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} @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))}. 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?} @section{What’s a txexpr?}

294
txexpr/tests.rkt
Unescape Escape View File

@ -1,158 +1,192 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base racket/syntax))
(require (submod "main.rkt" safe) rackunit)
(define-syntax (values->list stx) (define-syntax (eval-as-untyped stx)
(syntax-case stx () (syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)])) [(_ exprs ...)
(with-syntax ([sym (generate-temporary)])
(check-true (txexpr-tag?'foo)) #'(begin
(check-false (txexpr-tag? "foo")) (module sym racket
(check-false (txexpr-tag? 3)) (require rackunit (submod txexpr safe))
exprs ...)
(check-true (txexpr-attr? '(key "value"))) (require 'sym)))]))
(check-false (txexpr-attr? '(key "value" "another")))
(check-false (txexpr-attr? '(key 0 "value"))) (define-syntax (eval-as-typed stx)
(syntax-case stx ()
(check-true (txexpr-attrs? '())) [(_ exprs ...)
(check-true (txexpr-attrs? '((key "value")))) (with-syntax ([sym (generate-temporary)])
(check-true (txexpr-attrs? '((key "value") (foo "bar")))) #'(begin
(check-false (txexpr-attrs? '((key "value") "foo" "bar"))) ; content, not attr (module sym typed/racket
(check-false (txexpr-attrs? '(key "value"))) ; not a nested list (require typed/rackunit typed/txexpr)
(check-false (txexpr-attrs? '(("key" "value")))) ; two strings exprs ...)
(check-false (txexpr-attrs? '((key value)))) ; two symbols (require 'sym)))]))
(check-true (txexpr-element? "string")) (define-syntax-rule (eval-as-typed-and-untyped exprs ...)
(check-true (txexpr-element? 'amp)) (begin
(check-true (txexpr-element? '(p "string"))) (eval-as-typed exprs ...)
(check-true (txexpr-element? 65)) ;; a valid-char (eval-as-untyped exprs ...)))
(check-false (txexpr-element? 0)) ;; not a valid-char
(check-true (txexpr-elements? '("p" "foo" "123"))) (eval-as-typed-and-untyped
(check-true (txexpr-elements? '("p" "foo" 123))) ; includes number (define-syntax (values->list stx)
(check-true (txexpr-elements? '(p "foo" "123"))) ; includes symbol (syntax-case stx ()
(check-false (txexpr-elements? "foo")) ; not a list [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
(check-false (txexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr (check-true (txexpr-tag? 'foo))
(check-false (txexpr-elements? '("foo" "bar" ((key "value"))))) ; malformed (check-false (txexpr-tag? "foo"))
(check-false (txexpr-tag? 3))
(check-true (txexpr? '(p)))
(check-true (txexpr? '(p "foo" "bar"))) (check-true (txexpr-attr? '(key "value")))
(check-true (txexpr? '(p ((key "value")) "foo" "bar"))) (check-false (txexpr-attr? '(key "value" "another")))
(check-true (txexpr? '(p 123))) ; content is a number (check-false (txexpr-attr? '(key 0 "value")))
(check-false (txexpr? "foo")) ; not a list with symbol
(check-false (txexpr? '(p "foo" "bar" ((key "value"))))) ; malformed (check-true (txexpr-attrs? '()))
(check-false (txexpr? '("p" "foo" "bar"))) ; no name (check-true (txexpr-attrs? '((key "value"))))
(check-true (txexpr-attrs? '((key "value") (foo "bar"))))
(check-equal? (make-txexpr 'p) '(p)) (check-false (txexpr-attrs? '((key "value") "foo" "bar"))) ; content, not attr
(check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value")))) (check-false (txexpr-attrs? '(key "value"))) ; not a nested list
(check-equal? (make-txexpr 'p null '("foo" "bar")) '(p "foo" "bar")) (check-false (txexpr-attrs? '(("key" "value")))) ; two strings
(check-equal? (make-txexpr 'p '((key "value")) (list "foo" "bar")) (check-false (txexpr-attrs? '((key value)))) ; two symbols
'(p ((key "value")) "foo" "bar"))
(check-true (txexpr-element? "string"))
(check-equal? (values->list (txexpr->values '(p))) (check-true (txexpr-element? 'amp))
(values->list (values 'p null null))) (check-true (txexpr-element? '(p "string")))
(check-equal? (values->list (txexpr->values '(p "foo"))) (check-true (txexpr-element? 65)) ;; a valid-char
(values->list (values 'p null '("foo")))) (check-false (txexpr-element? 0)) ;; not a valid-char
(check-equal? (values->list (txexpr->values '(p ((key "value")))))
(values->list (values 'p '((key "value")) null))) (check-true (txexpr-elements? '("p" "foo" "123")))
(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) (check-true (txexpr-elements? '("p" "foo" 123))) ; includes number
(values->list (values 'p '((key "value")) '("foo")))) (check-true (txexpr-elements? '(p "foo" "123"))) ; includes symbol
(check-false (txexpr-elements? "foo")) ; not a list
(check-equal? (values->list (txexpr->values '(p))) (check-false (txexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr
(txexpr->list '(p))) (check-false (txexpr-elements? '("foo" "bar" ((key "value"))))) ; malformed
(check-equal? (values->list (txexpr->values '(p "foo")))
(txexpr->list '(p "foo"))) (check-true (txexpr? '(p)))
(check-equal? (values->list (txexpr->values '(p ((key "value"))))) (check-true (txexpr? '(p "foo" "bar")))
(txexpr->list '(p ((key "value"))))) (check-true (txexpr? '(p ((key "value")) "foo" "bar")))
(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) (check-true (txexpr? '(p 123))) ; content is a number
(txexpr->list '(p ((key "value")) "foo"))) (check-false (txexpr? "foo")) ; not a list with symbol
(check-false (txexpr? '(p "foo" "bar" ((key "value"))))) ; malformed
(check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p) (check-false (txexpr? '("p" "foo" "bar"))) ; no name
(check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value")))
(check-equal? (get-elements '(p ((key "value"))"foo" "bar" (em "square"))) (check-not-exn (λ _ (validate-txexpr '(p))))
'("foo" "bar" (em "square"))) (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-equal? (->txexpr-attr-key "foo") 'foo) ;(check-exn (λ _ (validate-txexpr "foo"))) ; not a list with symbol
(check-equal? (->txexpr-attr-key 'foo) 'foo) ;(check-exn (λ _ (validate-txexpr '(p "foo" "bar" ((key "value")))))) ; malformed
;(check-exn (λ _ (validate-txexpr '("p" "foo" "bar")))) ; no name
(check-equal? (->txexpr-attr-value "foo") "foo")
(check-equal? (->txexpr-attr-value 'foo) "foo")
(check-equal? (make-txexpr 'p) '(p))
(check-equal? (attrs->hash '((foo "bar"))) '#hash((foo . "bar"))) (check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value"))))
(check-equal? (attrs->hash '((foo "bar")) '(foo "fraw")) '#hash((foo . "fraw"))) (check-equal? (make-txexpr 'p null '("foo" "bar")) '(p "foo" "bar"))
(check-equal? (attrs->hash '((foo "bar")) '(foo "fraw") 'foo "dog") '#hash((foo . "dog"))) (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? (hash->attrs '#hash((foo . "bar")(hee . "haw"))) '((foo "bar")(hee "haw")))
(check-equal? (attr-ref '(p ((foo "bar"))) 'foo) "bar") (check-equal? (attr-ref '(p ((foo "bar"))) 'foo) "bar")
(check-equal? (attr-set '(p ((foo "bar"))) 'foo "fraw") '(p ((foo "fraw")))) (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-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-false (attrs-have-key? '((color "red")(shape "circle")) 'nonexistent))
(check-true (attrs-equal? '(p ((color "red")(shape "circle"))) (check-true (attrs-equal? '(p ((color "red")(shape "circle")))
'(foo ((color "red")(shape "circle"))))) '(foo ((color "red")(shape "circle")))))
(check-false (attrs-equal? '(p ((color "red")(shape "circle"))) (check-false (attrs-equal? '(p ((color "red")(shape "circle")))
'(foo ((color "blue")(shape "circle"))))) '(foo ((color "blue")(shape "circle")))))
(check-true (attrs-equal? '(p ((color "red")(shape "circle"))) (check-true (attrs-equal? '(p ((color "red")(shape "circle")))
'(foo ((shape "circle")(color "red"))))) '(foo ((shape "circle")(color "red")))))
(check-false (attrs-equal? '(p ((color "red")(shape "circle"))) (check-false (attrs-equal? '(p ((color "red")(shape "circle")))
'(foo ((color "red"))))) '(foo ((color "red")))))
(check-true (attrs-equal? '((color "red")(shape "circle")) (check-true (attrs-equal? '((color "red")(shape "circle"))
'((color "red")(shape "circle")))) '((color "red")(shape "circle"))))
(check-false (attrs-equal? '((color "red")(shape "circle")) (check-false (attrs-equal? '((color "red")(shape "circle"))
'((color "blue")(shape "circle")))) '((color "blue")(shape "circle"))))
(check-true (attrs-equal? '((color "red")(shape "circle")) (check-true (attrs-equal? '((color "red")(shape "circle"))
'((shape "circle")(color "red")))) '((shape "circle")(color "red"))))
(check-false (attrs-equal? '((color "red")(shape "circle")) (check-false (attrs-equal? '((color "red")(shape "circle"))
'((color "red")))) '((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"))) '((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 "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar")))
(check-equal? (merge-attrs (merge-attrs "foo" "bar" "goo" "gar") "hee" "haw") (check-equal? (merge-attrs (merge-attrs "foo" "bar" "goo" "gar") "hee" "haw")
'((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? (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 "hi"))
(check-equal? (remove-attrs '(p ((foo "bar")) "hi" (p ((foo "bar")) "hi"))) '(p "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)) (check-equal? (map-elements (λ(x) (if (string? x) "boing" x))
'(p "foo" "bar" (em "square"))) '(p "foo" "bar" (em "square")))
'(p "boing" "boing" (em "boing"))) '(p "boing" "boing" (em "boing")))
(check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") (check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2")
(em ((foo "zam")) "goodnight" "moon")) 'foo) '("bar" "zam" "zam")) (em ((foo "zam")) "goodnight" "moon")) 'foo) '("bar" "zam" "zam"))
(check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2") (check-equal? (attr-ref* '(root ((foo "bar")) "hello" "world" (meta ((foo "zam")) "bar2")
(em ((foo "zam")) "goodnight" "moon")) 'nonexistent-key) '()) (em ((foo "zam")) "goodnight" "moon")) 'nonexistent-key) '())
(define split-this-tx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2") (define split-this-tx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2")
(em "goodnight" "moon" (meta "foo3" "bar3")))) (em "goodnight" "moon" (meta "foo3" "bar3"))))
(define split-predicate (λ(x) (and (txexpr? x) (equal? 'meta (car x))))) (define split-predicate (λ(x) (and (txexpr? x) (equal? 'meta (car x)))))
(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate)) list) (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")))) (list '(root "hello" "world" (em "goodnight" "moon")) '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3"))))
(define split-proc (λ(x) '(div "foo"))) (define split-proc (λ(x) '(div "foo")))
(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx split-predicate split-proc)) list) (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")))) (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?")) (check-equal? (xexpr->html '(root (script "3 > 2") "Why is 3 > 2?"))
"<root><script>3 > 2</script>Why is 3 &gt; 2?</root>") "<root><script><![CDATA[3 > 2]]></script>Why is 3 &gt; 2?</root>"))

2
typed/txexpr/core-predicates.rkt
Unescape Escape View File

@ -26,8 +26,6 @@
(provide (all-from-out xml) cdata? xexpr->string) (provide (all-from-out xml) cdata? xexpr->string)
(define-type Valid-Char Natural) ;; overinclusive but that's as good as it gets (define-type Valid-Char Natural) ;; overinclusive but that's as good as it gets
(define-type Txexpr-Tag Symbol) (define-type Txexpr-Tag Symbol)
(define-type Txexpr-Attr-Key Symbol) (define-type Txexpr-Attr-Key Symbol)

4
typed/txexpr/main.rkt
Unescape Escape View File

@ -2,7 +2,7 @@
(require (for-syntax typed/racket/base) typed/sugar/define) (require (for-syntax typed/racket/base) typed/sugar/define)
(require racket/match racket/string racket/list racket/bool "core-predicates.rkt") (require racket/match racket/string racket/list racket/bool "core-predicates.rkt")
(provide (all-defined-out) (all-from-out "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]) (define/typed (validate-txexpr-attrs x #:context [txexpr-context #f])
((Txexpr-Attrs) (#:context Any) . ->* . Txexpr-Attrs) ((Txexpr-Attrs) (#:context Any) . ->* . Txexpr-Attrs)
(define/typed (make-reason) (define/typed (make-reason)
@ -14,7 +14,7 @@
"are not valid attributes" "are not valid attributes"
"is not in the form '(symbol \"string\")"))))) "is not in the form '(symbol \"string\")")))))
(cond (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: " [else (error (string-append "validate-txexpr-attrs: "
(if txexpr-context (format "in ~v, " txexpr-context) "") (if txexpr-context (format "in ~v, " txexpr-context) "")
(format "~v is not a valid list of attributes ~a" x (make-reason))))])) (format "~v is not a valid list of attributes ~a" x (make-reason))))]))

159
typed/txexpr/tests.rkt
Unescape Escape View File

@ -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 &gt; 2?</root>")
Write Preview
Loading…
Cancel
Save