From ca25159120f77a9ae5f2f1172f9541a222142ea4 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 4 Feb 2018 18:12:25 -0800 Subject: [PATCH] keep hope alive --- quad/quad/atomize.rkt | 79 ++++++++++++++++++++----------------------- quad/quad/qexpr.rkt | 51 ++++++++++++++++++++++++++++ 2 files changed, 88 insertions(+), 42 deletions(-) create mode 100644 quad/quad/qexpr.rkt diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 524086ec..5a0211ab 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -1,47 +1,42 @@ -#lang quad/dev -(require racket/string hyphenate) +#lang racket/base +(require racket/contract racket/match racket/list txexpr sugar/debug + "qexpr.rkt") (provide (all-defined-out)) -(define (atomize x) - (apply - vector-immutable - (flatten - (list - (let loop ([x x][loop-attrs default-attrs]) - (cond - [($shim? x) x] - [(string? x) - ;; consolidate consecutive whitespaces into single word space - ;; todo: hyphenate here? then they are in the quad stream - (for/list ([c (in-string x)]) - (cons - ;; installing loop attrs allows us to recognize contiguous runs later - ($shim loop-attrs #f #f) - ;; todo: is it feasible to box or otherwise object-ize a char - ;; so that all the quads with that char share that object - ;; and thus the measurement can be shared too? - ;; (object would have to be packaged with other typographic specs) - ((casev c - [(#\space) $space] - [(#\-) $hyphen] - [(#\u00AD) $shy] - [else $black]) loop-attrs #f c)))] - [else - (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))])) - ($eof (make-empty-attrs) #f #f))))) ; add eof so any in-vector loop consumes all the input vals - -(define (merge-runs xs) - ; combine quads with same attrs into sublists - (cond - [(empty? xs) empty] - [else - (define target (car xs)) - (define-values (matches rest) - (splitf-at (cdr xs) (λ(x) (eq? (quad-attrs target) (quad-attrs x))))) - (list* (cons target matches) (merge-runs rest))])) +(define/contract (atomize qx) + ;; normalize a qexpr by reducing it to one-character quads. + ;; propagate attrs downward by appending to front of attrs list. + ;; at then end, duplicates are removed, with frontmost attrs (= added later) given preference + (qexpr? . -> . (listof qexpr?)) + (let loop ([x qx][attrs null]) + (match x + [(? string?) (for/list ([c (in-string x)]) ;; strings are exploded + (qexpr attrs (string c)))] + [(list (? symbol?) (? txexpr-attrs? new-attrs) xs ...) ;; qexprs with attributes are recursed + (append* (for/list ([x (in-list xs)]) + (loop x (append new-attrs attrs))))] + [(list (? symbol? tag) xs ...) (loop (list* tag null xs) attrs)] ;; qexprs without attributes get null attrs + [else (raise-argument-error 'atomize "valid item" x)]))) (module+ test (require rackunit) - #;(atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux")) - (define qs (atomize (quad #f "A" (page-break) "B"))) - qs) + (check-equal? (atomize "Hi") '((q "H") (q "i"))) + (check-equal? (atomize '(q "Hi " (q "You"))) '((q "H") (q "i") (q " ") (q "Y") (q "o") (q "u"))) + (check-exn exn:fail? (λ () (atomize #t))) + + ;; with attributes + (check-equal? (atomize '(q ((k "v")) "Hi")) '((q ((k "v")) "H") (q ((k "v")) "i"))) + (check-equal? (atomize '(q ((k "v")) "Hi " (q "You"))) + '((q ((k "v")) "H") + (q ((k "v")) "i") + (q ((k "v")) " ") + (q ((k "v")) "Y") + (q ((k "v")) "o") + (q ((k "v")) "u"))) + (check-equal? (atomize '(q ((k1 "v1")(k2 "42")) "Hi " (q ((k1 "v2")(k3 "foo")) "You"))) + '((q ((k1 "v1")(k2 "42")) "H") + (q ((k1 "v1")(k2 "42")) "i") + (q ((k1 "v1")(k2 "42")) " ") + (q ((k1 "v2")(k3 "foo")(k2 "42")) "Y") + (q ((k1 "v2")(k3 "foo")(k2 "42")) "o") + (q ((k1 "v2")(k3 "foo")(k2 "42")) "u")))) \ No newline at end of file diff --git a/quad/quad/qexpr.rkt b/quad/quad/qexpr.rkt new file mode 100644 index 00000000..025945cd --- /dev/null +++ b/quad/quad/qexpr.rkt @@ -0,0 +1,51 @@ +#lang br +(require xml racket/contract txexpr) +(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?) (valid-tag? (get-tag x))] + [(list (? symbol? tag) (? char? c)) (valid-tag? tag)] + [(? 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/contract (qexpr attrs . elems) + ((txexpr-attrs?) #:rest txexpr-elements? . ->* . qexpr?) + (txexpr 'q (remove-duplicates attrs #:key car) 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")) "foo"))) + +(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