diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 72c51250..18162763 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -1,42 +1,53 @@ -#lang racket/base -(require racket/contract racket/match racket/list txexpr sugar/debug - "qexpr.rkt" "param.rkt") +#lang sugar/debug racket/base +(require racket/contract racket/match racket/list txexpr racket/dict + "quad.rkt" "qexpr.rkt" "param.rkt") (provide (all-defined-out)) +(define (update-with base-hash . update-hashes) + ;; starting with base-hash, add or update keys found in update-hashes + (apply hasheq (flatten (map hash->list (list* base-hash update-hashes))))) + +(module+ test + (check-equal? + ((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay")) + '#hasheq((zim . "BANG") (foo . "zay") (toe . "jam")))) + (define/contract (atomize qx) - ;; normalize a qexpr by reducing it to one-character quads. - ;; propagate attrs downward by appending to front of attrs list. - ;; ok to have duplicate attrs (leftmost attr takes precedence) - (qexpr? . -> . (listof qexpr?)) + ;; normalize a quad by reducing it to one-character quads. + ;; propagate attrs downward. + (quad? . -> . atomic-quads?) (let loop ([x qx][attrs (current-default-attrs)]) (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 + [(? char? c) (list (q attrs c))] + [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded + (loop c attrs)))] + [($quad this-attrs elems) ;; qexprs with attributes are recursed + (define merged-attrs (attrs . update-with . this-attrs)) + (append* (for/list ([elem (in-list elems)]) + (loop elem merged-attrs)))] [else (raise-argument-error 'atomize "valid item" x)]))) (module+ test (require rackunit) - (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))) + (check-equal? (atomize (q "Hi")) (list (q #\H) (q #\i))) + (check-equal? (atomize (q "Hi " (q "You"))) (list (q #\H) (q #\i) (q #\space) (q #\Y) (q #\o) (q #\u))) + (check-exn exn:fail:contract? (λ () (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") (k1 "v1") (k2 "42")) "Y") - (q ((k1 "v2") (k3 "foo") (k1 "v1") (k2 "42")) "o") - (q ((k1 "v2") (k3 "foo") (k1 "v1") (k2 "42")) "u")))) \ No newline at end of file + (check-equal? (atomize (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i))) + (check-equal? (atomize (q (hasheq 'k "v") "Hi " (q "You"))) + (list + ($quad '#hasheq((k . "v")) '(#\H)) + ($quad '#hasheq((k . "v")) '(#\i)) + ($quad '#hasheq((k . "v")) '(#\space)) + ($quad '#hasheq((k . "v")) '(#\Y)) + ($quad '#hasheq((k . "v")) '(#\o)) + ($quad '#hasheq((k . "v")) '(#\u)))) + (check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi " (q (hasheq 'k1 "v2" 'k3 "foo") "You"))) + (list + ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\H)) + ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\i)) + ($quad '#hasheq((k1 . "v1") (k2 . 42)) '(#\space)) + ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\Y)) + ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\o)) + ($quad '#hasheq((k1 . "v2") (k2 . 42) (k3 . "foo")) '(#\u))))) \ No newline at end of file diff --git a/quad/quad/param.rkt b/quad/quad/param.rkt index b2b275af..84e5aad1 100644 --- a/quad/quad/param.rkt +++ b/quad/quad/param.rkt @@ -1,5 +1,5 @@ #lang racket/base (provide (all-defined-out)) -(define current-default-attrs (make-parameter null)) +(define current-default-attrs (make-parameter (make-hasheq))) (define current-line-width (make-parameter 1)) \ No newline at end of file diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt new file mode 100644 index 00000000..f343b051 --- /dev/null +++ b/quad/quad/quad.rkt @@ -0,0 +1,33 @@ +#lang sugar/debug racket/base +(require racket/match racket/function) +(provide (all-defined-out)) +(module+ test (require rackunit)) + +(struct $quad (attrs elems) #:transparent) +(define quad? $quad?) +(define (quad-attrs? x) (and (hash? x) (hash-eq? x))) +(define (quad-elem? x) (or (char? x) (string? x) ($quad? x))) +(define (quad-elems? xs) (and (pair? xs) (andmap quad-elem? xs))) +(define (quad . xs) + (match xs + [(list #f xs ...) (apply quad (hasheq) xs)] + [(list (? quad-attrs? attrs) (? quad-elem? elems) ...) ($quad attrs elems)] + [(list (? quad-elem? elems) ...) (apply quad #f elems)] + [else (error 'bad-quad-input)])) +(define (quads? xs) (and (pair? xs) (andmap quad? xs))) +(define (atomic-quad? x) (and (quad? x) (match (qe x) + [(list (? char?)) #t] + [else #f]))) +(define (atomic-quads? xs) (and (pair? xs) (andmap atomic-quad? xs))) +(module+ test + (check-true (atomic-quad? ($quad '#hasheq() '(#\H)))) + (check-true (atomic-quads? (list ($quad '#hasheq() '(#\H)))))) + +(define quad-attrs $quad-attrs) +(define quad-elems $quad-elems) + +(define q quad) +(define q? quad?) +(define qs? quads?) +(define qa quad-attrs) +(define qe quad-elems)