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.
110 lines
3.7 KiB
Racket
110 lines
3.7 KiB
Racket
#lang debug racket/base
|
|
(require xml
|
|
racket/dict
|
|
racket/string
|
|
racket/match
|
|
racket/list
|
|
txexpr
|
|
"quad.rkt")
|
|
(provide (all-defined-out))
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
;; should we allow quads within a qexpr? I say yes
|
|
(define permissive-qexprs (make-parameter #t))
|
|
|
|
(define (valid-tag? tag) (and (memq tag '(q quad)) #t))
|
|
|
|
(define (qexpr? x)
|
|
;; a qexpr is like an xexpr, but more lenient in some ways (possibly allows quads)
|
|
;; and less in others (only allows 'q or 'quad as tag names, only allows strings or qexprs as elements)
|
|
;; attrs are open-ended
|
|
(match x
|
|
[(cons (? valid-tag?) rest)
|
|
(match rest
|
|
[(list (? txexpr-attrs?) (? qexpr?) ...) #t]
|
|
[(list (? qexpr?) ...) #t]
|
|
[_ #f])]
|
|
[(? string?) #t]
|
|
[(? quad?) (permissive-qexprs)]
|
|
[_ #f]))
|
|
|
|
|
|
(module+ test
|
|
(check-true (qexpr? "Hello world"))
|
|
(check-true (qexpr? '(q "Hello world")))
|
|
(check-true (qexpr? '(quad "Hello world")))
|
|
(check-false (qexpr? '(div "Hello world")))
|
|
(check-false (qexpr? '(q #\H)))
|
|
(check-false (qexpr? '(quad #\H)))
|
|
(check-false (qexpr? '(span #\H)))
|
|
(check-true (qexpr? '(quad "Hello world")))
|
|
(check-true (qexpr? `(quad "Hello " ,(q "world")))))
|
|
|
|
(define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$")))
|
|
|
|
(define (qexpr #:clean-attrs? [clean-attrs? #f]
|
|
#:name [name 'q]
|
|
attrs . elems)
|
|
(define new-attrs (if clean-attrs? (remove-duplicates attrs #:key car) attrs))
|
|
(define new-elems (match elems
|
|
[(list (? char? c)) (list (string c))]
|
|
[(list (? list? xs)) xs]
|
|
[else elems]))
|
|
(cond
|
|
[(empty? new-attrs) (list* name new-elems)]
|
|
[else (list* name new-attrs new-elems)]))
|
|
|
|
(module+ test
|
|
(check-equal? (qexpr null "foo") '(q "foo"))
|
|
(check-equal? (qexpr '((k "v")) "foo") '(q ((k "v")) "foo"))
|
|
(check-equal? (qexpr '((k "v2")(k "v1")) "foo") '(q ((k "v2")(k "v1")) "foo"))
|
|
(check-equal? (qexpr #:clean-attrs? #t '((k "v2")(k "v1")) "foo") '(q ((k "v2")) "foo")))
|
|
|
|
(define (hash->qattrs attr-hash)
|
|
(for/list ([(k v) (in-dict (hash->list attr-hash))])
|
|
(list k (format "~a" v))))
|
|
|
|
(define (quad->qexpr q)
|
|
(let loop ([x q])
|
|
(cond
|
|
[(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->qattrs (quad-attrs x)) (map loop (quad-elems x)))]
|
|
[else x])))
|
|
|
|
(define (qexpr->quad x)
|
|
(unless (qexpr? x)
|
|
(raise-argument-error 'qexpr->quad "qexpr" x))
|
|
(let loop ([x x])
|
|
(match x
|
|
[(cons (? valid-tag?) rest)
|
|
(match rest
|
|
[(list (? txexpr-attrs? attrs) (? qexpr? elems) ...)
|
|
(define mheq (make-hasheq)) ; want mutable hash
|
|
(for ([kv (in-list attrs)])
|
|
(match-define (list k v) kv)
|
|
;; coerce number strings to actual numbers
|
|
;; this misbehaves on a list index like "1." which becomes 1.0
|
|
(hash-set! mheq k (or (string->number v) (string-downcase v))))
|
|
(q #:attrs mheq #:elems (map loop elems))]
|
|
[(list (? qexpr? elems) ...)
|
|
(q #:elems (map loop elems))])]
|
|
[_ x])))
|
|
|
|
(module+ test
|
|
(check-true
|
|
(quad=?
|
|
(qexpr->quad `(q ((font "charter") (fontsize "12")) (q "Foo bar") ,(make-quad "zzz") (q "Zim Zam")))
|
|
(q (hasheq 'font "charter" 'fontsize 12) (q "Foo bar") (q "zzz") (q "Zim Zam")))))
|
|
|
|
(define (qml->qexpr x)
|
|
(parameterize ([permissive-xexprs #t]
|
|
[xexpr-drop-empty-attributes #t])
|
|
(string->xexpr x)))
|
|
|
|
(define (qexpr->qml x)
|
|
(xexpr->string x))
|
|
|
|
(module+ test
|
|
(check-equal? (qml->qexpr (qexpr->qml '(q "hi"))) '(q "hi"))
|
|
(check-equal? (qml->qexpr (qexpr->qml '(q () "hi"))) '(q "hi"))
|
|
(check-equal? (qml->qexpr (qexpr->qml '(q ((foo "bar")) "hi"))) '(q ((foo "bar")) "hi"))) |