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

benign refactorings

Browse Source
pull/5/head
Matthew Butterick 8 years ago
parent 59b95ec470
commit 8547d61ba6
2 changed files with 68 additions and 67 deletions
Show Stats Download Patch File Download Diff File

104
txexpr/base.rkt
Unescape Escape View File

@ -98,7 +98,7 @@
txexpr-attrs?
can-be-txexpr-attr-key?
can-be-txexpr-attr-value?))])
(test x)))
(test x)))
(define (validate-txexpr-attrs x #:context [txexpr-context #f])
@ -148,24 +148,27 @@
[else (error 'validate-txexpr (format "~v: not an X-expression" x))]))
(define+provide+safe (txexpr tag [attrs null] [elements null])
((symbol?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)
(define (txexpr-base func-name tag attrs elements)
(unless (txexpr-tag? tag)
(raise-argument-error 'txexpr "txexpr-tag?" tag))
(raise-argument-error func-name "txexpr-tag?" tag))
(unless (txexpr-attrs? attrs)
(raise-argument-error 'txexpr "txexpr-attrs?" attrs))
(raise-argument-error func-name "txexpr-attrs?" attrs))
(unless (txexpr-elements? elements)
(raise-argument-error 'txexpr "txexpr-elements?" elements))
(raise-argument-error func-name "txexpr-elements?" elements))
(define result (cons tag (append (if (empty? attrs) empty (list attrs)) elements)))
(unless (txexpr? result)
(error 'txexpr "not a txexpr"))
result)
(cons tag (append (if (empty? attrs)
empty
(list attrs)) elements)))
(define+provide+safe (txexpr tag [attrs null] [elements null])
((txexpr-tag?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)
(txexpr-base 'txexpr tag attrs elements))
(define+provide+safe (txexpr* tag [attrs null] . elements)
((symbol?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?)
(txexpr tag attrs elements))
((txexpr-tag?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?)
(txexpr-base 'txexpr* tag attrs elements))
(define make-txexpr txexpr) ; for backward compatability
@ -173,7 +176,7 @@
(define+provide+safe (txexpr->values x)
(txexpr? . -> . (values symbol? txexpr-attrs? txexpr-elements?))
(txexpr? . -> . (values txexpr-tag? txexpr-attrs? txexpr-elements?))
(if (txexpr-short? x)
(values (car x) '() (cdr x))
(values (car x) (cadr x) (cddr x))))
@ -181,8 +184,8 @@
(define+provide+safe (txexpr->list x)
(txexpr? . -> . list?)
(define-values (tag attrs content) (txexpr->values x))
(list tag attrs content))
(define-values (tag attrs elements) (txexpr->values x))
(list tag attrs elements))
;; convenience functions to retrieve only one part of txexpr
@ -193,7 +196,7 @@
(define+provide+safe (get-attrs x)
(txexpr? . -> . txexpr-attrs?)
(define-values (tag attrs content) (txexpr->values x))
(define-values (tag attrs elements) (txexpr->values x))
attrs)
@ -229,9 +232,9 @@
(for/hasheq ([sublist (in-list ((if hash-style-priority
identity
reverse) (slice-at items 2)))])
(let ([key (->txexpr-attr-key (first sublist))]
[value (->txexpr-attr-value (second sublist))])
(values key value))))
(let ([key (->txexpr-attr-key (first sublist))]
[value (->txexpr-attr-value (second sublist))])
(values key value))))
(define+provide+safe (hash->attrs attr-hash)
@ -249,6 +252,7 @@
(txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?)
(attr-set* tx key value))
(define+provide+safe (attr-set* tx . kvs)
((txexpr?) #:rest (listof (or/c can-be-txexpr-attr-key? can-be-txexpr-attr-value?)) . ->* . txexpr?)
;; unlike others, this uses hash operations to guarantee that your attr-set
@ -261,8 +265,7 @@
(append-map (λ(sublist)
(list (->txexpr-attr-key (first sublist))
(->txexpr-attr-value (second sublist)))) (slice-at kvs 2)))))
(txexpr (get-tag tx) new-attrs (get-elements tx)))
(txexpr-base 'attr-set* (get-tag tx) new-attrs (get-elements tx)))
(define+provide+safe (attr-join tx key value)
@ -273,7 +276,6 @@
(attr-set tx key (string-join `(,@starting-values ,value) " ")))
(define+provide+safe (attr-ref tx key [failure-result (λ _ (raise (make-exn:fail:contract (format "attr-ref: no value found for key ~v" key) (current-continuation-marks))))])
((txexpr? can-be-txexpr-attr-key?) (any/c) . ->* . any)
(define result (assq (->txexpr-attr-key key) (get-attrs tx)))
@ -284,22 +286,20 @@
failure-result)))
(define+provide+safe (remove-attrs x)
(txexpr? . -> . txexpr?)
(let loop ([x x])
(if (txexpr? x)
(let-values ([(tag attr elements) (txexpr->values x)])
(txexpr tag null (map loop elements)))
(let-values ([(tag attrs elements) (txexpr->values x)])
(cons tag (map loop elements)))
x)))
(define+provide+safe (map-elements proc x)
(procedure? txexpr? . -> . txexpr?)
(proc (if (txexpr? x)
(let-values ([(tag attr elements) (txexpr->values x)])
(txexpr tag attr (map (λ(e)(map-elements proc e)) elements)))
(let-values ([(tag attrs elements) (txexpr->values x)])
(txexpr tag attrs (map (λ(e)(map-elements proc e)) elements)))
x)))
@ -307,19 +307,19 @@
(define deleted-signal (gensym))
(define+provide+safe (splitf-txexpr tx pred [proc (λ(x) deleted-signal)])
((txexpr? procedure?) (procedure?) . ->* . (values txexpr? txexpr-elements?))
(unless (txexpr? tx)
(raise-argument-error 'splitf-txexpr "txexpr?" tx))
(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 elements) (txexpr->values x)])
(txexpr tag attr (filter (λ(e) (not (equal? e deleted-signal)))
(map do-extraction elements))))]
[(pred x) ;; store matched item and return processed value
(set! matches (cons x matches))
(proc x)]
[(txexpr? x) (let-values([(tag attrs elements) (txexpr->values x)])
(txexpr tag attrs (filter (λ(e) (not (eq? e deleted-signal)))
(map do-extraction elements))))]
[else x]))
(define tx-extracted (do-extraction tx)) ;; do this first to fill matches
(unless (txexpr? tx-extracted)
(error 'splitf-txexpr "Bad input"))
(values tx-extracted (reverse matches)))
@ -335,20 +335,22 @@
(and matches (car matches)))
;; don't use "![CDATA[...]]" wrapper in HTML, it's not consistent with the spec
(define (->cdata x)
(if (string? x)
(cdata #f #f x)
x))
(define+provide+safe (xexpr->html x)
(xexpr? . -> . string?)
(define (->cdata x)
(cond
[(cdata? x) x]
; don't use "![CDATA[...]]" wrapper in HTML, it's not consistent with the spec
[(string? x) (cdata #f #f x)]
[else x]))
(xexpr->string (let loop ([x x])
(cond
[(txexpr? x) (if (member (get-tag x) '(script style))
(txexpr (get-tag x) (get-attrs x)
(map ->cdata (get-elements x)))
(txexpr (get-tag x) (get-attrs x)
(map loop (get-elements x))))]
[else x]))))
(xexpr->string
(let loop ([x x])
(if (txexpr? x)
(let*-values ([(tag attrs elements) (txexpr->values x)]
[(proc) (if (memq tag '(script style))
->cdata
loop)])
;; a little faster than `txexpr` since we know the pieces are valid
(cons tag (append attrs (map proc elements))))
x))))

31
txexpr/tests.rkt
Unescape Escape View File

@ -4,24 +4,23 @@
;; use a separate test file to avoid cycle in loading
(define-syntax (test-safe-and-unsafe stx)
(syntax-case stx ()
[(_ exprs ...)
[(_ . exprs)
(with-syntax ([module-without-contracts (generate-temporary)]
[module-with-contracts (generate-temporary)])
(replace-context stx #'(begin
(module module-without-contracts racket
(require rackunit "main.rkt")
(define-syntax (values->list stx)
(syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
exprs ...)
(require 'module-without-contracts)
(module module-with-contracts racket
(require rackunit (submod "main.rkt" safe))
(define-syntax (values->list stx)
(syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
exprs ...)
(require 'module-with-contracts))))]))
(replace-context stx
#'(begin
(module module-without-contracts racket
(require rackunit "main.rkt")
(define-syntax-rule (values->list values-expr)
(call-with-values (λ () values-expr) list))
. exprs)
(require 'module-without-contracts)
(module module-with-contracts racket
(require rackunit (submod "main.rkt" safe))
(define-syntax-rule (values->list values-expr)
(call-with-values (λ () values-expr) list))
. exprs)
(require 'module-with-contracts))))]))
(test-safe-and-unsafe

Write Preview
Loading…
Cancel
Save