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

31
txexpr/tests.rkt
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save