You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
151 lines
4.9 KiB
Racket
151 lines
4.9 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base))
|
|
(require racket/contract racket/match xml racket/list)
|
|
|
|
(define-syntax (define+provide/contract stx)
|
|
(syntax-case stx ()
|
|
[(_ (proc arg ... . rest-arg) contract body ...)
|
|
#'(define+provide/contract proc contract
|
|
(λ(arg ... . rest-arg) body ...))]
|
|
[(_ name contract body ...)
|
|
#'(begin
|
|
(provide (contract-out [name contract]))
|
|
(define name body ...))]))
|
|
|
|
;; a tagged-xexpr consists of a tag, optional attributes, and then elements.
|
|
|
|
(define+provide/contract (tagged-xexpr-tag? x)
|
|
(any/c . -> . boolean?)
|
|
(symbol? x))
|
|
|
|
|
|
(define+provide/contract (tagged-xexpr-attr? x)
|
|
(any/c . -> . boolean?)
|
|
(match x
|
|
[(list (? symbol?) (? string?)) #t]
|
|
[else #f]))
|
|
|
|
(define+provide/contract (tagged-xexpr-attrs? x)
|
|
(any/c . -> . boolean?)
|
|
(match x
|
|
[(list (? tagged-xexpr-attr?) ...) #t]
|
|
[else #f]))
|
|
|
|
(define+provide/contract (tagged-xexpr-element? x)
|
|
(any/c . -> . boolean?)
|
|
(or (string? x) (tagged-xexpr? x) (symbol? x)
|
|
(valid-char? x) (cdata? x)))
|
|
|
|
(define+provide/contract (tagged-xexpr-elements? x)
|
|
(any/c . -> . boolean?)
|
|
(match x
|
|
[(list elem ...) (andmap tagged-xexpr-element? elem)]
|
|
[else #f]))
|
|
|
|
;; is it a named x-expression?
|
|
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
|
|
(define+provide/contract (tagged-xexpr? x)
|
|
(any/c . -> . boolean?)
|
|
(and (xexpr? x) ; meets basic xexpr contract
|
|
(match x
|
|
;; is a list starting with a symbol
|
|
[(list (? symbol? name) rest ...)
|
|
;; the rest is content or ...
|
|
(or (andmap tagged-xexpr-element? rest)
|
|
;; attr + content
|
|
(and (tagged-xexpr-attrs? (car rest)) (andmap tagged-xexpr-element? (cdr rest))))]
|
|
[else #f])))
|
|
|
|
|
|
(define+provide/contract (make-tagged-xexpr tag [attrs empty] [elements empty])
|
|
;; todo?: use xexpr/c provides a nicer error message
|
|
((symbol?) (tagged-xexpr-attrs? (listof tagged-xexpr-element?))
|
|
. ->* . tagged-xexpr?)
|
|
(filter-not empty? `(,tag ,attrs ,@elements)))
|
|
|
|
|
|
(define+provide/contract (tagged-xexpr->values x)
|
|
(tagged-xexpr? . -> .
|
|
(values symbol? tagged-xexpr-attrs? (listof tagged-xexpr-element?)))
|
|
(match
|
|
; tagged-xexpr may or may not have attr
|
|
; if not, add empty attr so that decomposition only handles one case
|
|
(match x
|
|
[(list _ (? tagged-xexpr-attrs?) _ ...) x]
|
|
[else `(,(car x) ,empty ,@(cdr x))])
|
|
[(list tag attr content ...) (values tag attr content)]))
|
|
|
|
|
|
(define+provide/contract (tagged-xexpr->list x)
|
|
(tagged-xexpr? . -> . list?)
|
|
(define-values (tag attrs content) (tagged-xexpr->values x))
|
|
(list tag attrs content))
|
|
|
|
|
|
;; convenience functions to retrieve only one part of tagged-xexpr
|
|
(define+provide/contract (tagged-xexpr-tag x)
|
|
(tagged-xexpr? . -> . tagged-xexpr-tag?)
|
|
(car x))
|
|
|
|
|
|
(define+provide/contract (tagged-xexpr-attrs x)
|
|
(tagged-xexpr? . -> . tagged-xexpr-attrs?)
|
|
(define-values (tag attrs content) (tagged-xexpr->values x))
|
|
attrs)
|
|
|
|
|
|
(define+provide/contract (tagged-xexpr-elements x)
|
|
(tagged-xexpr? . -> . (listof tagged-xexpr-element?))
|
|
(define-values (tag attrs elements) (tagged-xexpr->values x))
|
|
elements)
|
|
|
|
|
|
;; helpers. we are getting a string or symbol
|
|
(define (->symbol x)
|
|
(if (string? x) (string->symbol x) x))
|
|
|
|
(define (->string x)
|
|
(if (symbol? x) (symbol->string x) x))
|
|
|
|
|
|
;; convert list of alternating keys & values to attr
|
|
(define+provide/contract (merge-attrs . items)
|
|
(() #:rest (listof (or/c tagged-xexpr-attr? tagged-xexpr-attrs? symbol? string?)) . ->* . tagged-xexpr-attrs?)
|
|
|
|
;; need this function to make sure that 'foo and "foo" are treated as the same hash key
|
|
(define (make-attr-list items)
|
|
(if (empty? items)
|
|
empty
|
|
(let ([key (->symbol (first items))]
|
|
[value (->string (second items))]
|
|
[rest (drop items 2)])
|
|
(append (list key value) (make-attr-list rest)))))
|
|
|
|
;; use hash to ensure keys are unique (later values will overwrite earlier)
|
|
(define attr-hash (apply hash (make-attr-list (flatten items))))
|
|
`(,@(map (λ(k) (list k (hash-ref attr-hash k)))
|
|
;; sort needed for predictable results for unit tests
|
|
(sort (hash-keys attr-hash) (λ(a b) (string<? (->string a) (->string b)))))))
|
|
|
|
|
|
(define+provide/contract (remove-attrs x)
|
|
(tagged-xexpr? . -> . tagged-xexpr?)
|
|
(match x
|
|
[(? tagged-xexpr?) (let-values ([(tag attr elements) (tagged-xexpr->values x)])
|
|
(make-tagged-xexpr tag empty (remove-attrs elements)))]
|
|
[(? list?) (map remove-attrs x)]
|
|
[else x]))
|
|
|
|
|
|
(define+provide/contract (map-elements proc x)
|
|
(procedure? tagged-xexpr? . -> . tagged-xexpr?)
|
|
(define-values (tag attr elements) (tagged-xexpr->values x))
|
|
(define recursive-proc
|
|
(λ(x)
|
|
(cond
|
|
[(tagged-xexpr? x) (map-elements proc x)]
|
|
[else (proc x)])))
|
|
(make-tagged-xexpr tag attr (map recursive-proc elements)))
|
|
|
|
|