mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

a conundrum

Browse Source
main
Matthew Butterick 6 years ago
parent d7194e75f4
commit 4425b16241
7 changed files with 191 additions and 241 deletions
Show Stats Download Patch File Download Diff File

59
quad/qtest/hyphenate.rkt
Unescape Escape View File

@ -1,60 +1,5 @@
#lang qtest/markdown #lang qtest/markdown
# Hyphenate X
A simple _hyphenation engine_ that uses the Knuth–Liang hyphenation algorithm originally developed for TeX. Y
I **have added little** to their work. Accordingly, I take no credit, except a spoonful of *snako-bits.*
And now, for something __altogether__ the same. Yes! No?!ß
## 1. Installation
At the command line:
We said `raco pkg install hyphenate` dude
What?!
```
Code block
Goes here
```
> Hyphenate `xexpr` by calculating hyphenation points and inserting
`joiner` at those points. By default, `joiner` is the soft hyphen
\(Unicode 00AD = decimal 173\). Words shorter than
`#:min-length` `length` will not be hyphenated. To hyphenate words of
any length, use `#:min-length` `#f`.
A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text. A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text.A [list of web colors](https://en.wikipedia.org/wiki/Web_colors).
Certain word processors allow users to [insert soft
hyphens](http://practicaltypography.com/optional-hyphens.html) in their
text.

109
quad/qtest/markdown.rkt
Unescape Escape View File

@ -2,39 +2,37 @@
(require (for-syntax racket/base) txexpr racket/runtime-path racket/string racket/promise racket/match racket/list (require (for-syntax racket/base) txexpr racket/runtime-path racket/string racket/promise racket/match racket/list
pitfall quad sugar/debug pollen/tag) pitfall quad sugar/debug pollen/tag)
(provide (except-out (all-from-out racket/base) #%module-begin) (provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [mb #%module-begin] [q-tag q]) (rename-out [mb #%module-begin])
p id strong em attr-list h1 h2 code pre a blockquote) p id strong em attr-list h1 h2 code pre a blockquote)
(define-tag-function (p attrs exprs) (define-tag-function (p attrs exprs)
(txexpr 'q attrs exprs)) (qexpr attrs exprs))
(define-tag-function (blockquote attrs exprs) (define-tag-function (blockquote attrs exprs)
(txexpr 'q (cons '(container "bq") attrs) exprs)) (qexpr (cons '(container "bq") attrs) exprs))
(define id (default-tag-function 'id)) (define id (default-tag-function 'id))
(define class (default-tag-function 'class)) (define class (default-tag-function 'class))
(define q-tag (default-tag-function 'q))
(define-tag-function (strong attrs exprs) (define-tag-function (strong attrs exprs)
(txexpr 'q (cons '(font "charter-bold") attrs) exprs)) (qexpr (cons '(font "charter-bold") attrs) exprs))
(define-tag-function (a attrs exprs) (define-tag-function (a attrs exprs)
(txexpr 'q `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs)) (qexpr `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs))
(define-tag-function (em attrs exprs) (define-tag-function (em attrs exprs)
(txexpr 'q (cons '(font "charter-italic") attrs) exprs)) (qexpr (cons '(font "charter-italic") attrs) exprs))
(define-syntax-rule (attr-list . attrs) 'attrs) (define-syntax-rule (attr-list . attrs) 'attrs)
(define-tag-function (h1 attrs exprs) (define-tag-function (h1 attrs exprs)
(txexpr 'q (append '((font "fira")(fontsize "36")(line-height "48")) attrs) exprs)) (qexpr (append '((font "fira")(fontsize "36")(line-height "48")) attrs) exprs))
(define-tag-function (h2 attrs exprs) (define-tag-function (h2 attrs exprs)
(txexpr 'q (append '((font "fira")(fontsize "24")(line-height "36")) attrs) exprs)) (qexpr (append '((font "fira")(fontsize "24")(line-height "36")) attrs) exprs))
(define-tag-function (code attrs exprs) (define-tag-function (code attrs exprs)
(txexpr 'q (append '((font "fira-mono")(fontsize "11")(bg "aliceblue")) attrs) exprs)) (qexpr (append '((font "fira-mono")(fontsize "11")(bg "aliceblue")) attrs) exprs))
(define-tag-function (pre attrs exprs) (define-tag-function (pre attrs exprs)
;; pre needs to convert white space to equivalent layout elements ;; pre needs to convert white space to equivalent layout elements
@ -42,8 +40,8 @@
(for*/list ([expr (in-list exprs)] (for*/list ([expr (in-list exprs)]
[str (in-list (string-split (car (get-elements expr)) "\n"))]) [str (in-list (string-split (car (get-elements expr)) "\n"))])
`(,(get-tag expr) ,(get-attrs expr) ,str)) `(,(get-tag expr) ,(get-attrs expr) ,str))
'(q ""))) lbr))
(txexpr 'q attrs new-exprs)) (qexpr attrs new-exprs))
(define q:string (q #:in 'bi (define q:string (q #:in 'bi
#:out 'bo ;; align to baseline #:out 'bo ;; align to baseline
@ -70,30 +68,33 @@
(define-runtime-path fira-mono "fonts/fira-mono.ttf") (define-runtime-path fira-mono "fonts/fira-mono.ttf")
(define (->string-quad doc q) (define (->string-quad doc q)
(struct-copy (cond
quad q:string [(line-break? q) q]
[attrs (let ([attrs (quad-attrs q)]) [else
;; attrs hashes are shared between many quads. (struct-copy
;; so the first update will change every reference to the shared hash quad q:string
;; hence why we ignore if val is already a path [attrs (let ([attrs (quad-attrs q)])
;; but this op should ideally happen earlier ;; attrs hashes are shared between many quads.
(hash-update! attrs 'font ;; so the first update will change every reference to the shared hash
(λ (val) (if (path? val) ;; hence why we ignore if val is already a path
val ;; but this op should ideally happen earlier
(match (string-downcase (string-replace val " " "-")) (hash-update! attrs 'font
["charter" charter] (λ (val) (if (path? val)
["charter-bold" charter-bold] val
["charter-italic" charter-italic] (match (string-downcase (string-replace val " " "-"))
["fira" fira] ["charter" charter]
["fira-mono" fira-mono])))) ["charter-bold" charter-bold]
attrs)] ["charter-italic" charter-italic]
[elems (quad-elems q)] ["fira" fira]
[size (delay ["fira-mono" fira-mono]))))
(define fontsize (string->number (hash-ref (quad-attrs q) 'fontsize))) attrs)]
(font-size doc fontsize) [elems (quad-elems q)]
(font doc (path->string (hash-ref (quad-attrs q) 'font))) [size (delay
(define str (car (quad-elems q))) (define fontsize (string->number (hash-ref (quad-attrs q) 'fontsize)))
(pt (string-width doc str) (current-line-height doc)))])) (font-size doc fontsize)
(font doc (path->string (hash-ref (quad-attrs q) 'font)))
(define str (car (quad-elems q)))
(pt (string-width doc str) (current-line-height doc)))])]))
(define draw? #f) (define draw? #f)
(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"]) (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"])
@ -145,15 +146,29 @@
(values (cons new-run runs) rest))) (values (cons new-run runs) rest)))
(struct line-break quad ()) (struct line-break quad () #:transparent)
(define lbr (q #:type line-break
#:elems '("")
#:printable #f))
(struct para-break line-break () #:transparent)
(define pbr (q #:type para-break
#:elems '("¶¶")
#:printable #f))
(module+ test
(check-true (line-break? (second (quad-elems (q "foo" pbr "bar")))))
(check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
(define (line-wrap xs size) (define (line-wrap xs size)
(wrap xs size #R xs
#:hard-break (λ (q) (match (quad-elems q) #R (line-break? (second xs))
[(list (or "¶¶" "")) #t] (wrap xs size 'debug
[_ #f])) #:hard-break line-break?
#:soft-break soft-break-for-line? #:soft-break soft-break-for-line?
#:finish-wrap (λ (pcs q idx) #:finish-wrap (λ (pcs q idx)
#R pcs
#R q
#R idx
(define new-elems (consolidate-runs pcs)) (define new-elems (consolidate-runs pcs))
(append (append
(list (struct-copy quad q:line (list (struct-copy quad q:line
@ -187,6 +202,8 @@
#:draw-start (λ (q doc) (add-page doc)) #:draw-start (λ (q doc) (add-page doc))
#:draw-end (λ (q doc) #:draw-end (λ (q doc)
(font-size doc 10) (font-size doc 10)
(font doc charter)
(fill-color doc "black")
(text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number) (text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number)
(hash-ref (quad-attrs q) 'doc-title) (hash-ref (quad-attrs q) 'doc-title)
(date->string (current-date) #t)) (date->string (current-date) #t))
@ -265,8 +282,10 @@
#:size "letter"))) #:size "letter")))
(define line-width (- (pdf-width pdf) (* 2 side-margin))) (define line-width (- (pdf-width pdf) (* 2 side-margin)))
(define vertical-height (- (pdf-height pdf) top-margin bottom-margin)) (define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
(let* ([x (time-name runify (runify (qexpr->quad xs)))] (let* ([x (time-name atomize #R (atomize #R (qexpr->quad xs)))]
[x (begin #R (line-break? (second x)) x)]
[x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))] [x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))]
[x (begin #R (line-break? (second x)) x)]
[x (time-name line-wrap (line-wrap x line-width))] [x (time-name line-wrap (line-wrap x line-width))]
[x (time-name page-wrap (page-wrap x vertical-height path))] [x (time-name page-wrap (page-wrap x vertical-height path))]
[x (time-name insert-containers (insert-containers x))] [x (time-name insert-containers (insert-containers x))]
@ -277,7 +296,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ PDF-PATH . STRS) [(_ PDF-PATH . STRS)
#'(#%module-begin #'(#%module-begin
(define qx `(q ((font "Charter") (fontsize "12")) ,@(list . STRS))) (define qx (list* 'q '((font "Charter") (fontsize "12")) (add-between (list . STRS) pbr)))
(run qx PDF-PATH))])) (run qx PDF-PATH))]))
(module+ reader (module+ reader
@ -302,7 +321,7 @@
#:inside? #t #:inside? #t
#:command-char #\◊)) #:command-char #\◊))
(define stx (quad-at-reader path-string p)) (define stx (quad-at-reader path-string p))
(define parsed-stx (datum->syntax stx (xexpr->parse-tree (add-between (parse-markdown (apply string-append (syntax->datum stx))) '(q "¶¶"))))) (define parsed-stx (datum->syntax stx (xexpr->parse-tree (parse-markdown (apply string-append (syntax->datum stx))))))
(strip-context (strip-context
(with-syntax ([PT parsed-stx] (with-syntax ([PT parsed-stx]
[PDF-PATH (path-replace-extension path-string #".pdf")]) [PDF-PATH (path-replace-extension path-string #".pdf")])

2
quad/qtest/typewriter.rkt
Unescape Escape View File

@ -128,7 +128,7 @@
(time-name config-pdf (time-name config-pdf
(font pdf (path->string charter)) (font pdf (path->string charter))
(font-size pdf 12)) (font-size pdf 12))
(let* ([x (time-name runify (runify qarg))] (let* ([x (time-name atomize (atomize qarg))]
[x (time-name quadify (map (λ (x) (quadify pdf x)) x))] [x (time-name quadify (map (λ (x) (quadify pdf x)) x))]
[x (time-name line-wrap (line-wrap x line-width))] [x (time-name line-wrap (line-wrap x line-width))]
[x (time-name page-wrap (page-wrap x lines-per-page))] [x (time-name page-wrap (page-wrap x lines-per-page))]

160
quad/quad/atomize.rkt
Unescape Escape View File

@ -1,8 +1,16 @@
#lang debug racket/base #lang debug racket/base
(require racket/string racket/hash racket/class racket/match racket/list txexpr racket/dict racket/function (require racket/string
"quad.rkt" "param.rkt") racket/hash
racket/match
racket/list
txexpr
racket/function
"quad.rkt"
"param.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(module+ test (require rackunit))
(module+ test
(require rackunit))
(define (update-with base-hash . update-hashes) (define (update-with base-hash . update-hashes)
;; starting with base-hash, add or update keys found in update-hashes ;; starting with base-hash, add or update keys found in update-hashes
@ -15,72 +23,8 @@
((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay")) ((hasheq 'foo "bar" 'zim "zam") . update-with . (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
(make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam"))))) (make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam")))))
(define (merge-whitespace qs [white-q? (λ (aq) (char-whitespace? (car (quad-elems aq))))])
;; collapse each sequence of whitespace qs to the first one, and make it a space
;; also drop leading & trailing whitespaces
;; (same behavior as web browsers)
(let loop ([acc null][qs qs])
(if (null? qs)
(flatten acc)
(let*-values ([(bs rest) (splitf-at qs (negate white-q?))]
[(ws rest) (splitf-at rest white-q?)])
(loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws)
(pair? bs) ;; we follow bs
(pair? ws)) ;; we have ws
(make-quad (quad-attrs (car ws)) #\space)
null)) rest)))))
(module+ test
(check-equal? (merge-whitespace (list (q #\space) (q #\newline) (q #\H) (q #\space) (q #\newline) (q #\space) (q #\i) (q #\newline)))
(list (q #\H) (q #\space) (q #\i))))
(define (atomize qx)
;; normalize a quad by reducing it to one-character quads.
;; propagate attrs downward.
(define atomic-quads
(let loop ([x (if (string? qx) (q #f qx) qx)][attrs (current-default-attrs)])
(match x
[(? char? c) (list (q attrs c))]
[(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
(loop c attrs)))]
[(? quad?) ;; qexprs with attributes are recursed
(define this-attrs (quad-attrs x))
(define elems (quad-elems x))
(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)])))
(merge-whitespace atomic-quads))
(module+ test
(require rackunit)
(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)))
(check-equal? (atomize (q "H i")) (list (q #\H) (q #\space) (q #\i)))
(check-equal? (atomize (q "H \n\n i")) (list (q #\H) (q #\space) (q #\i))) ;; collapse whitespace to single
;; with attributes
(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
(q (hasheq 'k "v") #\H)
(q (hasheq 'k "v") #\i)
(q (hasheq 'k "v") #\space)
(q (hasheq 'k "v") #\Y)
(q (hasheq 'k "v") #\o)
(q (hasheq 'k "v") #\u)))
(check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (q (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
(list
(q (hasheq 'k1 "v1" 'k2 42) #\H)
(q (hasheq 'k1 "v1" 'k2 42) #\i)
(q (hasheq 'k1 "v1" 'k2 42) #\space)
(q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
(q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
(q (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
(define whitespace-pat #px"\\s+") (define whitespace-pat #px"\\s+")
(define (merge-and-isolate-white str) (define (merge-and-isolate-white str)
(for/list ([(m idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))] (for/list ([(m idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))]
#:when (non-empty-string? m)) #:when (non-empty-string? m))
@ -101,36 +45,54 @@
(define (same-run? qa qb) (define (same-run? qa qb)
(eq? (hash-ref (quad-attrs qa) run-key) (hash-ref (quad-attrs qb) run-key))) (eq? (hash-ref (quad-attrs qa) run-key) (hash-ref (quad-attrs qb) run-key)))
(define (runify qx) (define (atomize qx)
;; runify a quad by reducing it to a series of "runs", ;; atomize a quad by reducing it to the smallest indivisible formatting units.
;; which are multi-character quads with the same formatting. ;; which are multi-character quads with the same formatting.
(define first-run-idx (eq-hash-code (current-default-attrs))) (let loop ([x (make-quad qx)]
(define first-attrs (hash-copy (current-default-attrs))) [attrs (hash-copy (current-default-attrs))]
(hash-set! first-attrs run-key first-run-idx) [key (eq-hash-code (current-default-attrs))])
(dropf (match-define-values (next-key next-attrs)
(let loop ([x (if (string? qx) (make-quad #f (list qx)) qx)] ;; make a new run when we encounter non-empty attrs
[attrs first-attrs] (match (quad-attrs x)
[key first-run-idx]) [(? hash-empty?) (values key attrs)]
(match x [this-attrs (define next-key (eq-hash-code this-attrs))
[(? quad?) ;; qexprs with attributes are recursed (define next-attrs (attrs . update-with . this-attrs))
(define this-attrs (quad-attrs x)) (hash-set! next-attrs run-key next-key)
(define elems (quad-elems x)) (values next-key next-attrs)]))
(define next-key (if (hash-empty? this-attrs) key (eq-hash-code this-attrs))) (match (quad-elems x)
(define next-attrs (if (hash-empty? this-attrs) attrs (attrs . update-with . this-attrs))) [(? pair? elems)
(unless (hash-empty? this-attrs) (hash-set! next-attrs run-key next-key)) (append*
(append* (for/list ([elem (in-list (merge-adjacent-strings elems 'merge-white))]) (for/list ([elem (in-list (merge-adjacent-strings elems 'isolate-white))])
(if (string? elem) (match elem
(list (make-quad next-attrs elem)) [(? string?)
(loop elem next-attrs next-key))))])) #|
(λ (q) (string=? " " (car (quad-elems q)))))) 190116
The conundrum: how to atomize quads that have subtypes and possibly other fields.
We need to make new quads derived from the original.
But we don't have access to the subtype here.
Making the quad mutable doesn't solve the problem: we can change the first one, but we still need copies.
`struct-copy` doesn't work, because it can't see the subtype.
`struct-list` doesn't work, because it can't rely on structs being transparent.
|#
(list (make-quad #:type (quad-type x)
#:attrs next-attrs
#:elems (list elem)))]
[_ (loop elem next-attrs next-key)])))]
[_ (list x)])))
#;(module+ test (module+ test
;; this test doesn't work because of presence of 'idx and 'run keys (define (filter-private-keys qs)
(check-equal? (for-each (λ (q) (when (hash-has-key? (quad-attrs q) 'run)
(runify (q (hasheq 'foo 42) (q "Hi" " idiot" (q (hasheq 'bar 84) "There") "Eve" "ry" "one"))) (hash-remove! (quad-attrs q) 'run))) qs)
(list (q (hasheq 'foo 42) "Hi") qs)
(q (hasheq 'foo 42) " ") (struct $br quad ())
(q (hasheq 'foo 42) "idiot") (define br (q #:type $br (hasheq 'br "time")))
(q (hasheq 'foo 42 'bar 84) "There") (check-equal? (filter-private-keys (atomize (q (q "a b") br (q "x y"))))
(q (hasheq 'foo 42) "Everyone")))) (list (q "a") (q " ") (q "b") br (q "x") (q " ") (q "y")))
(check-equal?
(filter-private-keys (atomize (q (hasheq 'foo 42) (q "Hi" " idiot" (q (hasheq 'bar 84) "There") "Eve" "ry" "one"))))
(list (q (hasheq 'foo 42) "Hi")
(q (hasheq 'foo 42) " ")
(q (hasheq 'foo 42) "idiot")
(q (hasheq 'foo 42 'bar 84) "There")
(q (hasheq 'foo 42) "Everyone"))))

90
quad/quad/qexpr.rkt
Unescape Escape View File

@ -1,49 +1,59 @@
#lang debug racket/base #lang debug racket/base
(require xml (require xml
racket/contract
racket/class
racket/dict racket/dict
racket/string racket/string
racket/match racket/match
racket/list racket/list
txexpr txexpr
"quad.rkt" sugar/debug) "quad.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(module+ test (require rackunit)) (module+ test (require rackunit))
(define/contract (qexpr? x) ;; should we allow quads within a qexpr? I say yes
;; a qexpr is like an xexpr, but more lenient in some ways (allows single char as body element) (define permissive-qexprs (make-parameter #t))
;; 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))
(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 (match x
[(? txexpr?) #t] [(cons (? valid-tag?) rest)
[(list (? symbol? tag) (? char? c)) #t] (match rest
[(list (? txexpr-attrs?) (? qexpr?) ...) #t]
[(list (? qexpr?) ...) #t]
[_ #f])]
[(? string?) #t] [(? string?) #t]
[else #f])) [(? quad?) (permissive-qexprs)]
[_ #f]))
(module+ test (module+ test
(check-true (qexpr? "Hello world")) (check-true (qexpr? "Hello world"))
(check-true (qexpr? '(q "Hello world"))) (check-true (qexpr? '(q "Hello world")))
(check-true (qexpr? '(quad "Hello world"))) (check-true (qexpr? '(quad "Hello world")))
#;(check-false (qexpr? '(div "Hello world"))) (check-false (qexpr? '(div "Hello world")))
(check-true (qexpr? '(q #\H))) (check-false (qexpr? '(q #\H)))
(check-true (qexpr? '(quad #\H))) (check-false (qexpr? '(quad #\H)))
#;(check-false (qexpr? '(span #\H))) (check-false (qexpr? '(span #\H)))
(check-true (qexpr? '(quad "Hello world"))) (check-true (qexpr? '(quad "Hello world")))
(check-false (qexpr? 'q))) (check-true (qexpr? `(quad "Hello " ,(q "world")))))
(define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$"))) (define (quad-name q) (string->symbol (string-trim (symbol->string (object-name q)) "$")))
(define/contract (qexpr #:clean-attrs? [clean-attrs? #f] (define (qexpr #:clean-attrs? [clean-attrs? #f]
#:name [name 'q] #:name [name 'q]
attrs . elems) attrs . elems)
((txexpr-attrs?) (#:clean-attrs? any/c #:name txexpr-tag?) #:rest (or/c txexpr-elements? (list/c char?)) . ->* . qexpr?) (define new-attrs (if clean-attrs? (remove-duplicates attrs #:key car) attrs))
(txexpr name (if clean-attrs? (remove-duplicates attrs #:key car) attrs) (match elems (define new-elems (match elems
[(list (? char? c)) (list (string c))] [(list (? char? c)) (list (string c))]
[else elems]))) [(list (? list? xs)) xs]
[else elems]))
(cond
[(empty? new-attrs) (list* name new-elems)]
[else (list* name new-attrs new-elems)]))
(module+ test (module+ test
(check-equal? (qexpr null "foo") '(q "foo")) (check-equal? (qexpr null "foo") '(q "foo"))
@ -53,30 +63,38 @@
(define (hash->qattrs attr-hash) (define (hash->qattrs attr-hash)
(for/list ([(k v) (in-dict (hash->list attr-hash))]) (for/list ([(k v) (in-dict (hash->list attr-hash))])
(list k (format "~a" v)))) (list k (format "~a" v))))
(define/contract (quad->qexpr q) (define (quad->qexpr q)
(quad? . -> . qexpr?)
(let loop ([x q]) (let loop ([x q])
(cond (cond
[(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->qattrs (quad-attrs x)) (map loop (quad-elems x)))] [(quad? x) (apply qexpr #:name (quad-name x) #:clean-attrs? #t (hash->qattrs (quad-attrs x)) (map loop (quad-elems x)))]
[else x]))) [else x])))
(define/contract (qexpr->quad x) (define (qexpr->quad x)
(qexpr? . -> . quad?) (unless (qexpr? x)
(if (txexpr? x) (raise-argument-error 'qexpr->quad "qexpr" x))
(q #:attrs (attrs->hash (get-attrs x)) (let loop ([x x])
#:elems (map qexpr->quad (get-elements x))) (match x
x)) [(cons (? valid-tag?) rest)
(match rest
[(list (? txexpr-attrs? attrs) (? qexpr? elems) ...)
(q #:attrs (attrs->hash attrs) #:elems (map loop elems))]
[(list (? qexpr? elems) ...)
(q #:elems (map loop elems))])]
[_ x])))
(module+ test
(check-equal?
(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/contract (qml->qexpr x) (define (qml->qexpr x)
(string? . -> . qexpr?)
(parameterize ([permissive-xexprs #t] (parameterize ([permissive-xexprs #t]
[xexpr-drop-empty-attributes #t]) [xexpr-drop-empty-attributes #t])
(string->xexpr x))) (string->xexpr x)))
(define/contract (qexpr->qml x) (define (qexpr->qml x)
(qexpr? . -> . string?)
(xexpr->string x)) (xexpr->string x))
(module+ test (module+ test

9
quad/quad/quad.rkt
Unescape Escape View File

@ -34,7 +34,8 @@
;; and compare them key-by-key ;; and compare them key-by-key
(hashes-equal? (quad-attrs q1) (quad-attrs q2)))) (hashes-equal? (quad-attrs q1) (quad-attrs q2))))
(struct quad (attrs (struct quad (type
attrs
elems elems
size size
in in
@ -84,12 +85,16 @@
#:draw [draw default-draw] #:draw [draw default-draw]
#:draw-end [draw-end void] #:draw-end [draw-end void]
. args) . args)
(unless (andmap (λ (x) (not (pair? x))) elems)
(raise-argument-error 'make-quad "elements that are not lists" elems))
(match args (match args
[(list (== #false) elems ...) (make-quad #:elems elems)] [(list (== #false) elems ...) (make-quad #:elems elems)]
[(list (? hash? attrs) elems ...) (make-quad #:attrs attrs #:elems elems)] [(list (? hash? attrs) elems ...) (make-quad #:attrs attrs #:elems elems)]
[(list (? dict? assocs) elems ...) assocs (make-quad #:attrs (make-hasheq assocs) #:elems elems)] [(list (? dict? assocs) elems ...) assocs (make-quad #:attrs (make-hasheq assocs) #:elems elems)]
[(list elems ..1) (make-quad #:elems elems)] [(list elems ..1) (make-quad #:elems elems)]
[null (type attrs ;; all cases end up below
[null (type type
attrs
elems elems
size size
in in

3
quad/quad/wrap.rkt
Unescape Escape View File

@ -280,7 +280,8 @@
(define (visual-wrap str int [debug #f]) (define (visual-wrap str int [debug #f])
(string-join (string-join
(for/list ([x (in-list (linewrap (for/list ([atom (atomize str)]) (for/list ([x (in-list (linewrap (for/list ([c (in-string str)])
(define atom (q c))
(if (equal? (quad-elems atom) '(#\space)) (if (equal? (quad-elems atom) '(#\space))
(struct-copy quad sp) (struct-copy quad sp)
(struct-copy quad q-one (struct-copy quad q-one

Write Preview
Loading…
Cancel
Save