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

resume in typed tests

Browse Source
typed-work
Matthew Butterick 10 years ago
parent 7ac9431232
commit f14284df60
6 changed files with 240 additions and 351 deletions
Show Stats Download Patch File Download Diff File

2
info.rkt
Unescape Escape View File

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

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

@ -0,0 +1,3 @@
#lang racket/base
;; zilch

289
txexpr/main.rkt
Unescape Escape View File

@ -1,29 +1,10 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require sugar/include sugar/define xml)
(require racket/match xml racket/string racket/list racket/bool)
(module+ safe (require racket/contract)) (define+provide+safe (txexpr? x)
(define-syntax (define+provide+safe stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide+safe proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(define name body ...)
(provide name)
(module+ safe
(provide (contract-out [name contract]))))]))
(define+provide+safe (txexpr-tag? x)
(any/c . -> . boolean?)
(symbol? x))
(define+provide+safe (txexpr-tags? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(and (list? x) (andmap txexpr-tag? x))) (with-handlers ([exn:fail? (λ(exn) #f)])
(and (validate-txexpr x) #t)))
(define+provide+safe (txexpr-attr? x) (define+provide+safe (txexpr-attr? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
@ -31,264 +12,4 @@
[(list (? symbol?) (? string?)) #t] [(list (? symbol?) (? string?)) #t]
[else #f])) [else #f]))
(include-without-lang-line "../typed/txexpr/main.rkt")
(define (validate-txexpr-attrs x #:context [txexpr-context #f])
; ((any/c) (#:context (or/c #f txexpr?)) . ->* . txexpr-attrs?)
(define (make-reason)
(if (not (list? x))
(format "because ~v is not a list" x)
(let ([bad-attrs (filter (λ(i) (not (txexpr-attr? i))) x)])
(format "because ~a ~a" (string-join (map (λ(ba) (format "~v" ba)) bad-attrs) " and ") (if (> (length bad-attrs) 1)
"are not valid attributes"
"is not in the form '(symbol \"string\")")))))
(match x
[(list (? txexpr-attr?) ...) x]
[else [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))))]]))
(define+provide+safe (txexpr-attrs? x)
(any/c . -> . boolean?)
(with-handlers ([exn:fail? (λ(exn) #f)])
(and (validate-txexpr-attrs x) #t)))
(define+provide+safe (txexpr-elements? x)
(any/c . -> . boolean?)
(match x
[(list elem ...) (andmap txexpr-element? elem)]
[else #f]))
(define (validate-txexpr-element x #:context [txexpr-context #f])
; ((any/c) (#:context (or/c #f txexpr?)) . ->* . txexpr-element?)
(cond
[(or (string? x) (txexpr? x) (symbol? x)
(valid-char? x) (cdata? x)) x]
[else (error (string-append "validate-txexpr-element: "
(if txexpr-context (format "in ~v, " txexpr-context) "")
(format "~v is not a valid element (must be txexpr, string, symbol, XML char, or cdata)" x)))]))
(define+provide+safe (txexpr-element? x)
(any/c . -> . boolean?)
(with-handlers ([exn:fail? (λ(exn) #f)])
(and (validate-txexpr-element x) #t)))
;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
(define+provide+safe (validate-txexpr x)
(any/c . -> . txexpr?)
(define (validate-txexpr-element-with-context e) (validate-txexpr-element e #:context x))
(define (validate-txexpr-attrs-with-context e) (validate-txexpr-attrs e #:context x))
(when (match x
[(list (? symbol?)) #t]
[(list (? symbol? name) (and attr-list (list (list k v ...) ...)) rest ...)
(and (validate-txexpr-attrs-with-context attr-list)
(andmap validate-txexpr-element-with-context rest))]
[(list (? symbol? name) rest ...)(andmap validate-txexpr-element-with-context rest)]
[else (error (format "validate-txexpr: ~v is not a list starting with a symbol" x))])
x))
(define+provide+safe (txexpr? x)
(any/c . -> . boolean?)
(with-handlers ([exn:fail? (λ(exn) #f)])
(and (validate-txexpr x) #t)))
(define+provide+safe (make-txexpr tag [attrs null] [elements null])
;; todo?: use xexpr/c provides a nicer error message
((symbol?) (txexpr-attrs? txexpr-elements?)
. ->* . txexpr?)
(filter (compose1 not null?) `(,tag ,attrs ,@elements)))
(define+provide+safe (txexpr->values x)
(txexpr? . -> . (values symbol? txexpr-attrs? txexpr-elements?))
(match
; txexpr may or may not have attr
; if not, add null attr so that decomposition only handles one case
(match x
[(list _ (? txexpr-attrs?) _ ...) x]
[else `(,(car x) ,null ,@(cdr x))])
[(list tag attr content ...) (values tag attr content)]))
(define+provide+safe (txexpr->list x)
(txexpr? . -> . list?)
(define-values (tag attrs content) (txexpr->values x))
(list tag attrs content))
;; convenience functions to retrieve only one part of txexpr
(define+provide+safe (get-tag x)
(txexpr? . -> . txexpr-tag?)
(car x))
(define+provide+safe (get-attrs x)
(txexpr? . -> . txexpr-attrs?)
(define-values (tag attrs content) (txexpr->values x))
attrs)
(define+provide+safe (get-elements x)
(txexpr? . -> . txexpr-elements?)
(define-values (tag attrs elements) (txexpr->values x))
elements)
;; helpers. we are getting a string or symbol
(define+provide+safe (->txexpr-attr-key x)
(can-be-txexpr-attr-key? . -> . txexpr-attr-key?)
(if (string? x) (string->symbol x) x))
(define+provide+safe (->txexpr-attr-value x)
(can-be-txexpr-attr-value? . -> . txexpr-attr-value?)
(->string x))
(define+provide+safe (txexpr-attr-key? x)
(any/c . -> . boolean?)
(symbol? x))
(define+provide+safe (can-be-txexpr-attr-key? x)
(any/c . -> . boolean?)
(or (symbol? x) (string? x)))
(define+provide+safe (txexpr-attr-value? x)
(any/c . -> . boolean?)
(string? x))
(define (txexpr-attr-values? xs) (and (list? xs) (andmap txexpr-attr-value? xs)))
(define+provide+safe (can-be-txexpr-attr-value? x)
(any/c . -> . boolean?)
(can-be-txexpr-attr-key? x))
(define (->string x)
(if (symbol? x) (symbol->string x) x))
(define+provide+safe (can-be-txexpr-attrs? x)
(any/c . -> . boolean?)
(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)))
(define+provide+safe (attrs->hash . items)
(() #:rest list-of-can-be-txexpr-attrs? . ->* . hash?)
;; can be liberal with input because they're all just nested key/value pairs
;; but still need this function to make sure that 'foo and "foo" are treated as the same hash key
(define (make-key-value-list items)
(if (null? items)
null
(let ([key (->txexpr-attr-key (car items))]
[value (->txexpr-attr-value (cadr items))]
[rest (cddr items)])
(cons (cons key value) (make-key-value-list rest)))))
(make-immutable-hash (make-key-value-list (flatten items))))
(define+provide+safe (hash->attrs hash)
(hash? . -> . txexpr-attrs?)
(hash-map hash list))
(define+provide+safe (attrs-have-key? x key)
((or/c txexpr-attrs? txexpr?) can-be-txexpr-attr-key? . -> . boolean?)
(define attrs (if (txexpr-attrs? x) x (get-attrs x)))
(hash-has-key? (attrs->hash attrs) (->txexpr-attr-key key)))
(define+provide+safe (attrs-equal? x1 x2)
((or/c txexpr-attrs? txexpr?) (or/c txexpr-attrs? txexpr?) . -> . boolean?)
(define attrs-tx1 (attrs->hash (if (txexpr-attrs? x1) x1 (get-attrs x1))))
(define attrs-tx2 (attrs->hash (if (txexpr-attrs? x2) x2 (get-attrs x2))))
(and
(= (length (hash-keys attrs-tx1)) (length (hash-keys attrs-tx2)))
(for/and ([(key value) (in-hash attrs-tx1)])
(equal? (hash-ref attrs-tx2 key) value))))
(define+provide+safe (attr-set tx key value)
(txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?)
(define new-attrs
(hash->attrs (hash-set (attrs->hash (get-attrs tx)) (->txexpr-attr-key key) (->txexpr-attr-value value))))
(make-txexpr (get-tag tx) new-attrs (get-elements tx)))
(define+provide+safe (attr-ref tx key)
(txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-value?)
(with-handlers ([exn:fail? (λ(e) (error (format "attr-ref: no value found for key ~v" key)))])
(hash-ref (attrs->hash (get-attrs tx)) key)))
(define+provide+safe (attr-ref* tx key)
(txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-values?)
(filter-not false?
(flatten
(let loop ([tx tx])
(and (txexpr? tx)
(cons (and (attrs-have-key? tx key)(attr-ref tx key))
(map loop (get-elements tx))))))))
;; convert list of alternating keys & values to attr
(define+provide+safe (merge-attrs . items)
(() #:rest list-of-can-be-txexpr-attrs? . ->* . txexpr-attrs?)
(define attrs-hash (apply attrs->hash items))
;; sort needed for predictable results for unit tests
(define sorted-hash-keys (sort (hash-keys attrs-hash) (λ(a b) (string<? (->string a) (->string b)))))
`(,@(map (λ(key) (list key (hash-ref attrs-hash key))) sorted-hash-keys)))
(define+provide+safe (remove-attrs x)
(txexpr? . -> . txexpr?)
(cond
[(txexpr? x) (let-values ([(tag attr elements) (txexpr->values x)])
(make-txexpr tag null (remove-attrs elements)))]
[(txexpr-elements? x) (map remove-attrs x)]
[else x]))
;; todo: exclude-proc will keep things out, but is there a way to keep things in?
(define+provide+safe (map-elements/exclude proc x exclude-test)
(procedure? txexpr? procedure? . -> . txexpr?)
(cond
[(txexpr? x)
(if (exclude-test x)
x
(let-values ([(tag attr elements) (txexpr->values x)])
(make-txexpr tag attr
(map (λ(x)(map-elements/exclude proc x exclude-test)) elements))))]
;; externally the function only accepts txexpr,
;; but internally we don't care
[else (proc x)]))
(define+provide+safe (map-elements proc x)
(procedure? txexpr? . -> . txexpr?)
(map-elements/exclude proc x (λ(x) #f)))
;; function to split tag out of txexpr
(define+provide+safe (splitf-txexpr tx pred [proc (λ(x) null)])
((txexpr? procedure?) (procedure?) . ->* . (values txexpr? txexpr-elements?))
(define matches null)
(define (do-extraction x)
(cond
[(pred x) (begin ; store matched item and return processed value
(set! matches (cons x matches))
(proc x))]
[(txexpr? x) (let-values([(tag attr body) (txexpr->values x)])
(make-txexpr tag attr (do-extraction body)))]
[(txexpr-elements? x) (filter (compose1 not null?) (map do-extraction x))]
[else x]))
(define tx-extracted (do-extraction tx)) ;; do this first to fill matches
(values tx-extracted (reverse matches)))
(define+provide+safe (xexpr->html x)
(xexpr? . -> . string?)
(define (->cdata x)
(if (cdata? x) x (cdata #f #f x)))
(xexpr->string (let loop ([x x])
(cond
[(txexpr? x) (if (member (get-tag x) '(script style))
(make-txexpr (get-tag x) (get-attrs x) (map ->cdata (get-elements x)))
(make-txexpr (get-tag x) (get-attrs x) (map loop (get-elements x))))]
[else x]))))

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

@ -1,10 +1,18 @@
#lang typed/racket/base #lang typed/racket/base
(require (for-syntax racket/base) racket/match) (require (for-syntax racket/base) racket/match typed/sugar/define)
(provide (all-defined-out) valid-char? cdata?) (provide (all-defined-out))
; Section 2.2 of XML 1.1
; (XML 1.0 is slightly different and more restrictive)
(define/typed (valid-char? i)
(Any -> Boolean)
(and (exact-nonnegative-integer? i)
(or (<= #x1 i #xD7FF)
(<= #xE000 i #xFFFD)
(<= #x10000 i #x10FFFF))))
(require/typed (require/typed
xml xml
[valid-char? (Any -> Boolean)]
[#:struct location ([line : (Option Natural)] [#:struct location ([line : (Option Natural)]
[char : (Option Natural)] [char : (Option Natural)]
[offset : Natural])] [offset : Natural])]
@ -13,7 +21,12 @@
[#:struct (cdata source) ([string : String])] [#:struct (cdata source) ([string : String])]
[#:struct comment ([text : String])] [#:struct comment ([text : String])]
[#:struct (p-i source) ([target-name : Symbol] [#:struct (p-i source) ([target-name : Symbol]
[instruction : String])]) [instruction : String])]
[xexpr->string (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)
@ -40,17 +53,9 @@
comment comment
p-i)) p-i))
(define-syntax (define/typed stx)
(syntax-case stx ()
[(_ (proc-name arg ... . rest-arg) type-expr body ...)
#'(define/typed proc-name type-expr
(λ(arg ... . rest-arg) body ...))]
[(_ proc-name type-expr body ...)
#'(begin
(: proc-name type-expr)
(define proc-name body ...))]))
(define-predicate txexpr? Txexpr) (define-predicate txexpr? Txexpr)
(define-predicate txexpr-short? Txexpr-Short)
(define-predicate txexpr-tag? Txexpr-Tag) (define-predicate txexpr-tag? Txexpr-Tag)
(define-predicate txexpr-tags? (Listof Txexpr-Tag)) (define-predicate txexpr-tags? (Listof Txexpr-Tag))
(define-predicate txexpr-attr? Txexpr-Attr) (define-predicate txexpr-attr? Txexpr-Attr)
@ -65,4 +70,4 @@
(define-predicate can-be-txexpr-attr? (List Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value)) (define-predicate can-be-txexpr-attr? (List Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value))
(define-type Can-Be-Txexpr-Attr (U Txexpr-Attr Txexpr-Attrs Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value)) (define-type Can-Be-Txexpr-Attr (U Txexpr-Attr Txexpr-Attrs Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value))
(define-predicate can-be-txexpr-attrs? Can-Be-Txexpr-Attr) (define-predicate can-be-txexpr-attrs? Can-Be-Txexpr-Attr)
(define-predicate list-of-can-be-txexpr-attrs? (Listof Can-Be-Txexpr-Attr)) (define-predicate list-of-can-be-txexpr-attrs? (Listof Can-Be-Txexpr-Attr))

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

@ -1,11 +1,10 @@
#lang typed/racket/base #lang typed/racket/base
(require (for-syntax typed/racket/base)) (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"))
(define/typed (validate-txexpr-attrs x #:context [txexpr-context #f]) (define/typed (validate-txexpr-attrs x #:context [txexpr-context #f])
((Any) (#:context Boolean) . ->* . Txexpr-Attrs) ((Txexpr-Attrs) (#:context Any) . ->* . Txexpr-Attrs)
(define/typed (make-reason) (define/typed (make-reason)
(-> String) (-> String)
(if (not (list? x)) (if (not (list? x))
@ -22,10 +21,10 @@
(define/typed (validate-txexpr-element x #:context [txexpr-context #f]) (define/typed (validate-txexpr-element x #:context [txexpr-context #f])
((Any) (#:context Any) . ->* . Txexpr-Element) ((Txexpr-Element) (#:context Any) . ->* . Txexpr-Element)
(cond (cond
[(or (string? x) (txexpr? x) (symbol? x) [(or (string? x) (txexpr? x) (symbol? x)
(valid-char? x) (cdata? x)) (cast x Txexpr-Element)] (valid-char? x) (cdata? x)) x]
[else (error (string-append "validate-txexpr-element: " [else (error (string-append "validate-txexpr-element: "
(if txexpr-context (format "in ~v, " txexpr-context) "") (if txexpr-context (format "in ~v, " txexpr-context) "")
(format "~v is not a valid element (must be txexpr, string, symbol, XML char, or cdata)" x)))])) (format "~v is not a valid element (must be txexpr, string, symbol, XML char, or cdata)" x)))]))
@ -34,35 +33,30 @@
;; is it a named x-expression? ;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging) ;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
(define/typed (validate-txexpr x) (define/typed (validate-txexpr x)
(Any -> Txexpr) (Any -> (Option Txexpr))
(define-syntax-rule (validate-txexpr-element-with-context e) (validate-txexpr-element e #:context x))
(define-syntax-rule (validate-txexpr-attrs-with-context e) (validate-txexpr-attrs e #:context x)) (define-syntax-rule (validate-txexpr-attrs-with-context e) (validate-txexpr-attrs e #:context x))
(if (match x (define-syntax-rule (validate-txexpr-element-with-context e) (validate-txexpr-element e #:context x))
[(list (? symbol?)) #t] (cond
;; todo: fix this condition [(txexpr-short? x) x]
#;[(list (? symbol?) (and attr-list (list (list k v ...) ...)) rest ...) [(txexpr? x) (and
(and (validate-txexpr-attrs-with-context (cast attr-list Txexpr-Attrs)) (validate-txexpr-attrs-with-context (get-attrs x))
(andmap (λ(e) (validate-txexpr-element-with-context e)) rest))] (andmap (λ([e : Txexpr-Element]) (validate-txexpr-element-with-context e)) (get-elements x)) x)]
[(list (? symbol? name) rest ...)(andmap (λ(e) (validate-txexpr-element-with-context e)) rest)] [else (error 'validate-txexpr (format "~v is not a list starting with a symbol" x))]))
[else (error 'validate-txexpr (format "~v is not a list starting with a symbol" x))])
(cast x Txexpr)
(error 'validate-txexpr "Can't reach this")))
(define/typed (make-txexpr tag [attrs null] [elements null]) (define/typed (make-txexpr tag [attrs null] [elements null])
((Symbol) (Txexpr-Attrs (Listof Txexpr-Element)) . ->* . Txexpr) ((Symbol) (Txexpr-Attrs (Listof Txexpr-Element)) . ->* . Txexpr)
(cast (cons tag (append (if (empty? attrs) empty (list attrs)) elements)) Txexpr)) (define result (cons tag (append (if (empty? attrs) empty (list attrs)) elements)))
(if (txexpr? result)
result
(error 'make-txexpr "This can't happen")))
(define/typed (txexpr->values x) (define/typed (txexpr->values x)
(Txexpr -> (values Txexpr-Tag Txexpr-Attrs Txexpr-Elements)) (Txexpr -> (values Txexpr-Tag Txexpr-Attrs Txexpr-Elements))
(match (if (txexpr-short? x)
; txexpr may or may not have attr (values (car x) '() (cdr x))
; if not, add null attr so that decomposition only handles one case (values (car x) (cadr x) (cddr x))))
(match x
[(list _ (? txexpr-attrs?) _ ...) x]
[else `(,(car x) ,null ,@(cdr x))])
[(list tag attr content ...) (values tag (cast attr Txexpr-Attrs) (cast content Txexpr-Elements))]))
(define/typed (txexpr->list x) (define/typed (txexpr->list x)
@ -113,12 +107,12 @@
(for/fold ([items : (Listof (U Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value)) null]) (for/fold ([items : (Listof (U Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value)) null])
([i (in-list items-in)]) ([i (in-list items-in)])
(cond (cond
[(txexpr-attr? i) (append i items)] [(txexpr-attr? i) (append (reverse i) items)]
[(txexpr-attrs? i) (append (append* i) items)] [(txexpr-attrs? i) (append (append* (map (λ([a : Txexpr-Attr]) (reverse a)) i)) items)]
[else (cons i items)])))) [else (cons i items)]))))
(define/typed (make-key-value-list items) (define/typed (make-key-value-list items)
((Listof (U Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value)) -> (Listof (Pairof Txexpr-Attr-Key Txexpr-Attr-Value))) ((Listof (U Can-Be-Txexpr-Attr-Key Can-Be-Txexpr-Attr-Value)) -> (Listof (Pairof Txexpr-Attr-Key Txexpr-Attr-Value)))
(if (>= (length items) 2) (if (< (length items) 2)
null null
(let ([key (->txexpr-attr-key (car items))] (let ([key (->txexpr-attr-key (car items))]
[value (->txexpr-attr-value (cadr items))] [value (->txexpr-attr-value (cadr items))]
@ -175,7 +169,7 @@
;; convert list of alternating keys & values to attr ;; convert list of alternating keys & values to attr
(define/typed (merge-attrs . items) (define/typed (merge-attrs . items)
(Txexpr-Attr * -> Txexpr-Attrs) (Can-Be-Txexpr-Attr * -> Txexpr-Attrs)
(define attrs-hash (apply attrs->hash items)) (define attrs-hash (apply attrs->hash items))
;; sort needed for predictable results for unit tests ;; sort needed for predictable results for unit tests
(define sorted-hash-keys (sort (hash-keys attrs-hash) (λ([a : Txexpr-Tag][b : Txexpr-Tag]) (string<? (->string a) (->string b))))) (define sorted-hash-keys (sort (hash-keys attrs-hash) (λ([a : Txexpr-Tag][b : Txexpr-Tag]) (string<? (->string a) (->string b)))))
@ -189,52 +183,59 @@
(make-txexpr tag null (map remove-attrs elements))) (make-txexpr tag null (map remove-attrs elements)))
x)) x))
#|
;; todo: exclude-proc will keep things out, but is there a way to keep things in?
(define+provide+safe (map-elements/exclude proc x exclude-test) (define/typed (map-elements/exclude proc x exclude-test)
(procedure? txexpr? procedure? . -> . txexpr?) ((Xexpr -> Xexpr) Xexpr (Xexpr -> Boolean) -> Xexpr)
(cond (cond
[(txexpr? x) [(txexpr? x)
(if (exclude-test x) (if (exclude-test x)
x x
(let-values ([(tag attr elements) (txexpr->values x)]) (let-values ([(tag attr elements) (txexpr->values x)])
(make-txexpr tag attr (make-txexpr tag attr
(map (λ(x)(map-elements/exclude proc x exclude-test)) elements))))] (map (λ([x : Xexpr])(map-elements/exclude proc x exclude-test)) elements))))]
;; externally the function only accepts txexpr, ;; externally the function only accepts txexpr,
;; but internally we don't care ;; but internally we don't care
[else (proc x)])) [else (proc x)]))
(define+provide+safe (map-elements proc x)
(procedure? txexpr? . -> . txexpr?) (define/typed (map-elements proc x)
((Xexpr -> Xexpr) Xexpr -> Xexpr)
(map-elements/exclude proc x (λ(x) #f))) (map-elements/exclude proc x (λ(x) #f)))
;; function to split tag out of txexpr ;; function to split tag out of txexpr
(define+provide+safe (splitf-txexpr tx pred [proc (λ(x) null)]) (define deleted-signal (gensym))
((txexpr? procedure?) (procedure?) . ->* . (values txexpr? txexpr-elements?)) (define/typed (splitf-txexpr tx pred [proc (λ([x : Xexpr]) deleted-signal)])
(define matches null) ((Txexpr (Xexpr -> Boolean)) ((Xexpr -> Xexpr)) . ->* . (values Txexpr Txexpr-Elements))
(define (do-extraction x) (define matches : Txexpr-Elements null)
(define/typed (do-extraction x)
(Xexpr -> Xexpr)
(cond (cond
[(pred x) (begin ; store matched item and return processed value [(pred x) (begin ; store matched item and return processed value
(set! matches (cons x matches)) (set! matches (cons x matches))
(proc x))] (proc x))]
[(txexpr? x) (let-values([(tag attr body) (txexpr->values x)]) [(txexpr? x) (let-values([(tag attr elements) (txexpr->values x)])
(make-txexpr tag attr (do-extraction body)))] (make-txexpr tag attr (filter (λ([e : Xexpr]) (not (equal? e deleted-signal))) (map do-extraction elements))))]
[(txexpr-elements? x) (filter (compose1 not null?) (map do-extraction x))]
[else x])) [else x]))
(define tx-extracted (do-extraction tx)) ;; do this first to fill matches (define tx-extracted (do-extraction tx)) ;; do this first to fill matches
(values tx-extracted (reverse matches))) (values (if (txexpr? tx-extracted)
tx-extracted
(define+provide+safe (xexpr->html x) (error 'splitf-txexpr "Can't get here")) (reverse matches)))
(xexpr? . -> . string?)
(define (->cdata x)
(if (cdata? x) x (cdata #f #f x))) (define/typed (xexpr->html x)
(Xexpr -> String)
(xexpr->string (let loop ([x x]) (define/typed (->cdata x)
(Xexpr -> Xexpr)
(cond
[(cdata? x) x]
[(string? x) (cdata #f #f (format "<![CDATA[~a]]>" x))]
[else x]))
(xexpr->string (let loop : Xexpr ([x : Xexpr x])
(cond (cond
[(txexpr? x) (if (member (get-tag x) '(script style)) [(txexpr? x) (if (member (get-tag x) '(script style))
(make-txexpr (get-tag x) (get-attrs x) (map ->cdata (get-elements x))) (make-txexpr (get-tag x) (get-attrs x) (map ->cdata (get-elements x)))
(make-txexpr (get-tag x) (get-attrs x) (map loop (get-elements x))))] (make-txexpr (get-tag x) (get-attrs x) (map loop (get-elements x))))]
[else x])))) [else x]))))
|#

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

@ -0,0 +1,159 @@
#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