diff --git a/quad/quadwriter/query.rkt b/quad/quadwriter/query.rkt index 6951f771..43fe64f9 100644 --- a/quad/quadwriter/query.rkt +++ b/quad/quadwriter/query.rkt @@ -3,7 +3,9 @@ (provide (all-defined-out)) (define (make-linear-index q) - (cons q (append-map make-linear-index (quad-elems q)))) + (if (quad? q) + (cons q (append-map make-linear-index (quad-elems q))) + null)) (define (string->pred str) (match str @@ -16,13 +18,13 @@ (define (parse-query str) (for/list ([piece (in-list (string-split str ":"))]) - (match (regexp-match #px"^(.*)\\[(.*?)\\]$" piece) - [#false (cons (string->pred piece) #false)] - [(list all name arg) (cons (string->pred name) (or (string->number arg) - (string->symbol arg)))]))) + (match (regexp-match #px"^(.*)\\[(.*?)\\]$" piece) + [#false (cons (string->pred piece) #false)] + [(list all name arg) (cons (string->pred name) (or (string->number arg) + (string->symbol arg)))]))) -(define (query q query-str) - (for/fold ([qs (make-linear-index q)] +(define (query qs query-str) + (for/fold ([qs qs] #:result (and qs (car qs))) ([query-piece (in-list (parse-query query-str))]) (match-define (cons pred count) query-piece) @@ -41,12 +43,12 @@ (define-syntax-rule (factory type proc) (make-quad #:type type #:elems (for/list ([i (in-range 3)]) - (set! counter (add1 counter)) - (define new-q (proc)) - (quad-update! new-q - [tag (format "~a[~a]-~a" 'proc counter (gensym))]) - (hash-set! (quad-attrs new-q) 'count counter) - new-q))) + (set! counter (add1 counter)) + (define new-q (proc)) + (quad-update! new-q + [tag (format "~a[~a]-~a" 'proc counter (gensym))]) + (hash-set! (quad-attrs new-q) 'count counter) + new-q))) (define (line) (make-quad #:type line-quad)) (define (block) (factory block-quad line)) diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index 25ab73d0..1deba215 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -28,7 +28,8 @@ "doc.rkt" "column.rkt" "keep.rkt" - "debug.rkt") + "debug.rkt" + "query.rkt") (provide (all-defined-out)) @@ -57,7 +58,7 @@ #:min-left-length 3 #:min-right-length 3))] [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) - (struct-copy quad q [elems (list substr)]))] + (struct-copy quad q [elems (list substr)]))] [else (list q)])) @@ -66,12 +67,12 @@ (unless (even? (length pcs)) (raise-argument-error 'string->feature-list "even number of tags and values" pcs)) (for/list ([kv (in-slice 2 pcs)]) - (cons (match (first kv) - [(? string? k) (string->bytes/utf-8 k)] - [k (raise-argument-error 'string->feature-list "string" k)]) - (match (string->number (second kv)) - [(? number? num) num] - [v (raise-argument-error 'string->feature-list "number string" v)])))) + (cons (match (first kv) + [(? string? k) (string->bytes/utf-8 k)] + [k (raise-argument-error 'string->feature-list "string" k)]) + (match (string->number (second kv)) + [(? number? num) num] + [v (raise-argument-error 'string->feature-list "number string" v)])))) (define (parse-font-features! attrs) ;; `font-features` are OpenType font feature specifiers. @@ -106,7 +107,7 @@ ;; we parse them into the equivalent measurement in points. (for ([k (in-hash-keys attrs)] #:when (takes-dimension-string? k)) - (hash-update! attrs k (λ (val) (parse-dimension val attrs)))) + (hash-update! attrs k (λ (val) (parse-dimension val attrs)))) attrs) (define (downcase-values! attrs) @@ -114,9 +115,9 @@ ;; so we can check them more easily later. (for ([k (in-hash-keys attrs)] #:unless (has-case-sensitive-value? k)) - (hash-update! attrs k (λ (val) (match val - [(? string? str) (string-downcase str)] - [_ val])))) + (hash-update! attrs k (λ (val) (match val + [(? string? str) (string-downcase str)] + [_ val])))) attrs) (define (complete-every-path! attrs) @@ -125,7 +126,7 @@ ;; relies on `current-directory` being parameterized to source file's dir (for ([k (in-hash-keys attrs)] #:when (takes-path? k)) - (hash-update! attrs k (compose1 path->string path->complete-path))) + (hash-update! attrs k (compose1 path->string path->complete-path))) attrs) (define (handle-cascading-attrs attrs) @@ -138,7 +139,7 @@ ;; because they can be denoted relative to em size parse-dimension-strings! parse-font-features!))]) - (proc attrs))) + (proc attrs))) (define (drop-leading-breaks qs) ;; any leading breaks are pointless at the start of the doc, so drop them. @@ -163,7 +164,7 @@ (define (get-define-val q) (quad-ref q 'define)) (define-values (dqs not-dqs) (partition get-define-val qs)) (for ([dq-group (in-list (group-by get-define-val dqs))]) - (hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group)) + (hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group)) not-dqs) (define default-line-height-multiplier 1.42) @@ -256,9 +257,9 @@ (cons :pdf-keywords 'Keywords)))] [str (in-value (and (pair? qs) (quad-ref (car qs) k)))] #:when str) - (cons pdf-k str)))) + (cons pdf-k str)))) (for ([(k v) (in-dict kv-dict)]) - (hash-set! (pdf-info pdf) k v))) + (hash-set! (pdf-info pdf) k v))) (define (footnote-flow? q) (equal? (quad-ref q 'flow) "footnote")) @@ -292,19 +293,19 @@ (for ([page (in-list (for*/list ([sec (in-list secs)] [elem (in-list (quad-elems sec))] #:when (page-quad? elem)) - elem))] + elem))] [page-num (in-naturals 1)] [page-side (in-cycle '(right left))]) - (define repeaters-for-this-page - (for/list ([repeater (in-list repeaters)] - #:when (let* ([val (quad-ref repeater :page-repeat)] - [sym (string->symbol val)]) - (or (eq? sym 'all) - (eq? sym page-side) - (eq? sym (if (= page-num 1) 'first 'rest))))) - repeater)) - (when (pair? repeaters-for-this-page) - (set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) + (define repeaters-for-this-page + (for/list ([repeater (in-list repeaters)] + #:when (let* ([val (quad-ref repeater :page-repeat)] + [sym (string->symbol val)]) + (or (eq? sym 'all) + (eq? sym page-side) + (eq? sym (if (= page-num 1) 'first 'rest))))) + repeater)) + (when (pair? repeaters-for-this-page) + (set-quad-elems! page (append repeaters-for-this-page (quad-elems page))))) secs) (define (make-sections all-qs) @@ -355,20 +356,20 @@ (for/list ([page (in-list section-pages-without-repeaters)] [page-num (in-naturals 1)] [page-side (in-cycle ((if (eq? section-starting-side 'right) values reverse) '(right left)))]) - (define section-repeaters-for-this-page - (for/list ([repeater (in-list section-repeaters)] - #:when (let* ([val (quad-ref repeater :page-repeat)] - [sym (string->symbol (string-trim val #px"section\\s"))]) - (or (eq? sym 'section) - (eq? sym 'all) - (eq? sym page-side) - (eq? sym (if (= page-num 1) 'first 'rest))))) - repeater)) - (cond - [(null? section-repeaters-for-this-page) page] - [else - (quad-copy page-quad page - [elems (append section-repeaters-for-this-page (quad-elems page))])]))) + (define section-repeaters-for-this-page + (for/list ([repeater (in-list section-repeaters)] + #:when (let* ([val (quad-ref repeater :page-repeat)] + [sym (string->symbol (string-trim val #px"section\\s"))]) + (or (eq? sym 'section) + (eq? sym 'all) + (eq? sym page-side) + (eq? sym (if (= page-num 1) 'first 'rest))))) + repeater)) + (cond + [(null? section-repeaters-for-this-page) page] + [else + (quad-copy page-quad page + [elems (append section-repeaters-for-this-page (quad-elems page))])]))) (begin0 (cond @@ -401,25 +402,13 @@ (section-pages-used (+ (section-pages-used) (length section-pages)))))) (define (resolve-parents doc) - ;; resolve location of any quad with a dynamic anchor-parent attribute like @line:1 - (for* ([section (in-list (quad-elems doc))] - [(page page-idx) (in-indexed (quad-elems section))] - #:when (page-quad? page)) - (define unresolved-qs - (let loop ([x page]) - (match x - [(? quad?) ((if (quad-ref x :anchor-parent) - (λ (tail) (cons x tail)) - values) (append-map loop (quad-elems x)))] - [_ null]))) - (for ([line (in-list (quad-elems page))] - [line-num (in-naturals 1)] - #:when (line-quad? line)) - (define line-key (format "@line:~a" line-num)) - #R line-key - (for ([uq (in-list unresolved-qs)] - #:when (equal? (quad-ref uq :anchor-parent) line-key)) - (quad-update! line [elems (append (quad-elems line) (list uq))])))) + (define linearized-qs (make-linear-index doc)) + (for* ([q (in-list linearized-qs)] + [query-str (in-value (quad-ref q :anchor-parent))] + #:when query-str + [parent (in-value (query linearized-qs query-str))] + #:when parent) + (quad-update! parent [elems (append (quad-elems parent) (list q))])) doc) (define (correct-line-alignment doc) @@ -429,16 +418,16 @@ (for* ([section (in-list (quad-elems doc))] [(page page-idx) (in-indexed (quad-elems section))] #:when (page-quad? page)) - (define right-side? (odd? (add1 page-idx))) - (define zero-filler-side (if right-side? "inner" "outer")) - (let loop ([x page]) - (cond - [(and (line-quad? x) - (equal? zero-filler-side (quad-ref x :line-align)) - (filler-quad? (car (quad-elems x)))) - ;; collapse the filler quad by setting size to 0 - (set-quad-size! (car (quad-elems x)) (pt 0 0))] - [(quad? x) (for-each loop (quad-elems x))]))) + (define right-side? (odd? (add1 page-idx))) + (define zero-filler-side (if right-side? "inner" "outer")) + (let loop ([x page]) + (cond + [(and (line-quad? x) + (equal? zero-filler-side (quad-ref x :line-align)) + (filler-quad? (car (quad-elems x)))) + ;; collapse the filler quad by setting size to 0 + (set-quad-size! (car (quad-elems x)) (pt 0 0))] + [(quad? x) (for-each loop (quad-elems x))]))) doc) (define/contract (render-pdf qx-arg