diff --git a/quad/qtest/typewriter.rkt b/quad/qtest/typewriter.rkt index 4b17e1dd..9af984d2 100644 --- a/quad/qtest/typewriter.rkt +++ b/quad/qtest/typewriter.rkt @@ -172,9 +172,12 @@ #'(#%module-begin (define qs (list . QS)) (define lotsa-qs (append* (make-list (string->number (string-trim REP)) qs))) - (run (apply quad (hasheq 'fontsize "12") lotsa-qs) PS) + (run (qexpr->quad (apply quad #:fontsize "12" lotsa-qs)) PS) (void)))])) +(define quad (default-tag-function 'quad)) +(provide quad) + (module reader syntax/module-reader qtest/typewriter #:read quad-read diff --git a/quad/quad/main.rkt b/quad/quad/main.rkt index 8f9e3cb4..eb1cc047 100644 --- a/quad/quad/main.rkt +++ b/quad/quad/main.rkt @@ -2,12 +2,14 @@ (require "atomize.rkt" "quad.rkt" +"qexpr.rkt" "break.rkt" "position.rkt" "param.rkt") (provide (all-from-out "atomize.rkt" "quad.rkt" +"qexpr.rkt" "break.rkt" "position.rkt" "param.rkt")) \ No newline at end of file diff --git a/quad/quad/qexpr.rkt b/quad/quad/qexpr.rkt new file mode 100644 index 00000000..a044e622 --- /dev/null +++ b/quad/quad/qexpr.rkt @@ -0,0 +1,84 @@ +#lang debug racket/base +(require xml + racket/contract + racket/class + racket/dict + racket/string + racket/match + racket/list + txexpr + "quad.rkt" sugar/debug) +(provide (all-defined-out)) + +(module+ test (require rackunit)) + +(define/contract (qexpr? x) + ;; a qexpr is like an xexpr, but more lenient in some ways (allows single char as body element) + ;; and less in others (only allows 'q or 'quad as tag names) + (any/c . -> . boolean?) + (define (valid-tag? tag) (and (memq tag '(q quad)) #t)) + (match x + [(? txexpr?) #t] + [(list (? symbol? tag) (? char? c)) #t] + [(? string?) #t] + [else #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-true (qexpr? '(q #\H))) + (check-true (qexpr? '(quad #\H))) + #;(check-false (qexpr? '(span #\H))) + (check-true (qexpr? '(quad "Hello world"))) + (check-false (qexpr? 'q))) + +(define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$"))) + +(define/contract (qexpr #:clean-attrs? [clean-attrs? #f] + #:name [name 'q] + attrs . elems) + ((txexpr-attrs?) (#:clean-attrs? any/c #:name txexpr-tag?) #:rest (or/c txexpr-elements? (list/c char?)) . ->* . qexpr?) + (txexpr name (if clean-attrs? (remove-duplicates attrs #:key car) attrs) (match elems + [(list (? char? c)) (list (string c))] + [else 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/contract (quad->qexpr q) + (quad? . -> . qexpr?) + (let loop ([x q]) + (cond + [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->qattrs (send x attrs)) (map loop (send x elems)))] + [else x]))) + +(define/contract (qexpr->quad x) + (qexpr? . -> . quad?) + (if (txexpr? x) + (make-object quad% (attrs->hash (get-attrs x)) (map qexpr->quad (get-elements x))) + x)) + +(define/contract (qml->qexpr x) + (string? . -> . qexpr?) + (parameterize ([permissive-xexprs #t] + [xexpr-drop-empty-attributes #t]) + (string->xexpr x))) + +(define/contract (qexpr->qml x) + (qexpr? . -> . string?) + (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"))) \ No newline at end of file