diff --git a/quad/qtest/all.rkt b/quad/qtest/all.rkt index edcf5dfd..9dfcf2dc 100644 --- a/quad/qtest/all.rkt +++ b/quad/qtest/all.rkt @@ -11,7 +11,7 @@ (with-syntax ([PDF-NAME (test-pdf-name (syntax-e #'PATH))]) #'(begin (parameterize ([quadwriter-test-mode #t]) - (render-pdf (dynamic-require PATH 'doc) PDF-NAME)) + (render-pdf (dynamic-require PATH 'doc) PDF-NAME PATH)) (make-test-pdf . REST)))])) (define-syntax (test-each stx) @@ -26,7 +26,7 @@ (define-runtime-path path (path-replace-extension MOD-PATH #".pdf")) (check-pdfs-equal? (time (parameterize ([quadwriter-test-mode #t] [current-output-port (open-output-nowhere)]) - (render-pdf (dynamic-require path-to-test 'doc) path) + (render-pdf (dynamic-require path-to-test 'doc) path path-to-test) path)) test-base) (test-each . REST)))])) diff --git a/quad/quadwriter/attrs.rkt b/quad/quadwriter/attrs.rkt index ac8de53b..c961872f 100644 --- a/quad/quadwriter/attrs.rkt +++ b/quad/quadwriter/attrs.rkt @@ -183,4 +183,7 @@ Naming guidelines :font-size :font-tracking :font-baseline-shift - :line-height)) #true)) \ No newline at end of file + :line-height)) #true)) + +(define (takes-path? k) + (and (memq k (list :image-file)) #true)) \ No newline at end of file diff --git a/quad/quadwriter/lang-helper.rkt b/quad/quadwriter/lang-helper.rkt index 73bd29b3..ab3f4027 100644 --- a/quad/quadwriter/lang-helper.rkt +++ b/quad/quadwriter/lang-helper.rkt @@ -70,7 +70,7 @@ (current-output-port) (λ () (with-logging-to-port (current-output-port) - (λ () (render-pdf DOC pdf-path)) + (λ () (render-pdf DOC pdf-path PATH-STRING)) #:logger quadwriter-logger 'debug)) #:logger quad-logger diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index c4e72f11..71ff4c4e 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -34,10 +34,10 @@ [(_ ALL-BREAKS-ID . TYPES) (with-syntax ([((TYPE-BREAK TYPE-STR Q:TYPE-BREAK) ...) (for/list ([type (in-list (syntax->list #'TYPES))]) - (list - (format-id #'TYPES "~a-break" type) - (symbol->string (syntax->datum type)) - (format-id #'TYPES "q:~a-break" type)))]) + (list + (format-id #'TYPES "~a-break" type) + (symbol->string (syntax->datum type)) + (format-id #'TYPES "q:~a-break" type)))]) #'(begin (define TYPE-BREAK '(q ((break TYPE-STR)))) ... (define ALL-BREAKS-ID (list (cons TYPE-BREAK Q:TYPE-BREAK) ...))))])) @@ -56,22 +56,22 @@ ;; do this before ->string-quad so that it can handle the sizing promises (apply append (for/list ([q (in-list qs)]) - (match (quad-ref q :hyphenate) - [#true #:when (and (pair? (quad-elems q)) - (andmap string? (quad-elems q))) - (for*/list ([str (in-list (quad-elems q))] - [hyphen-char (in-value #\u00AD)] - [hstr (in-value (hyphenate str hyphen-char - #: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)]))] - [_ (list q)])))) + (match (quad-ref q :hyphenate) + [#true #:when (and (pair? (quad-elems q)) + (andmap string? (quad-elems q))) + (for*/list ([str (in-list (quad-elems q))] + [hyphen-char (in-value #\u00AD)] + [hstr (in-value (hyphenate str hyphen-char + #: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)]))] + [_ (list q)])))) (define (string->feature-list str) (for/list ([kv (in-slice 2 (string-split str))]) - (cons (string->bytes/utf-8 (first kv)) (string->number (second kv))))) + (cons (string->bytes/utf-8 (first kv)) (string->number (second kv))))) (define (parse-font-features! attrs) (cond @@ -93,11 +93,19 @@ (define (parse-dimension-strings! attrs) (for ([k (in-hash-keys attrs)] #:when (takes-dimension-string? k)) - (hash-set! attrs k (parse-dimension (hash-ref attrs k)))) + (hash-set! attrs k (parse-dimension (hash-ref attrs k)))) + attrs) + +(define (complete-every-path! attrs) + ;; relies on `current-directory` being parameterized to source file's dir + (for ([(k v) (in-hash attrs)] + #:when (takes-path? k)) + (hash-set! attrs k (path->string (path->complete-path v)))) attrs) (define (handle-cascading-attrs attrs) (parse-dimension-strings! attrs) + (complete-every-path! attrs) (resolve-font-path! attrs) (resolve-font-size! attrs) (parse-font-features! attrs)) @@ -161,11 +169,18 @@ (define (setup-column-gap qs) (or (debug-column-gap) (quad-ref (car qs) :column-gap default-column-gap))) -(define/contract (render-pdf qx-arg pdf-path-arg +(define/contract (render-pdf qx-arg pdf-path-arg [base-dir-arg #f] #:replace [replace-existing-file? #t] #:compress [compress? #t]) - ((qexpr? (or/c #false path? path-string?)) (#:replace any/c - #:compress any/c) . ->* . (or/c void? bytes?)) + ((qexpr? (or/c #false path? path-string?)) + ((or/c #false path? path-string?) + #:replace any/c + #:compress any/c) . ->* . (or/c void? bytes?)) + + (define base-dir (match base-dir-arg + [#false (current-directory)] + [path (define-values (dir name _) (split-path path)) + dir])) (define pdf-path (setup-pdf-path pdf-path-arg)) (unless replace-existing-file? @@ -176,31 +191,34 @@ #:auto-first-page #false #:output-path pdf-path)) (parameterize ([current-pdf the-pdf] + ;; set `current-directory` so that ops like `path->complete-path` + ;; will be handled relative to the original directory + [current-directory base-dir] [verbose-quad-printing? #false]) (define qs (time-log setup-qs (setup-qs qx-arg pdf-path))) (define sections (for/list ([qs (in-list (filter-split qs section-break-quad?))]) - (match-define (list page-width page-height) (parse-page-size (and (pair? qs) (car qs)))) - (match-define (list left-margin top-margin right-margin bottom-margin) - (setup-margins qs page-width page-height)) - (define printable-width (- page-width left-margin right-margin)) - (define printable-height (- page-height top-margin bottom-margin)) - (define column-count (setup-column-count qs)) - (define column-gap (setup-column-gap qs)) + (match-define (list page-width page-height) (parse-page-size (and (pair? qs) (car qs)))) + (match-define (list left-margin top-margin right-margin bottom-margin) + (setup-margins qs page-width page-height)) + (define printable-width (- page-width left-margin right-margin)) + (define printable-height (- page-height top-margin bottom-margin)) + (define column-count (setup-column-count qs)) + (define column-gap (setup-column-gap qs)) - (define line-wrap-size (/ (- printable-width (* (sub1 column-count) column-gap)) column-count)) - (define line-qs (time-log line-wrap (apply-keeps (line-wrap qs line-wrap-size)))) + (define line-wrap-size (/ (- printable-width (* (sub1 column-count) column-gap)) column-count)) + (define line-qs (time-log line-wrap (apply-keeps (line-wrap qs line-wrap-size)))) - (define col-quad-prototype (struct-copy quad q:column - [size (pt line-wrap-size printable-height)])) - (define column-qs (time-log column-wrap (column-wrap line-qs printable-height column-gap col-quad-prototype))) + (define col-quad-prototype (struct-copy quad q:column + [size (pt line-wrap-size printable-height)])) + (define column-qs (time-log column-wrap (column-wrap line-qs printable-height column-gap col-quad-prototype))) - (define page-quad-prototype (struct-copy quad q:page - [shift (pt left-margin top-margin)] - [size (pt line-wrap-size printable-height)])) - (define page-qs (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) + (define page-quad-prototype (struct-copy quad q:page + [shift (pt left-margin top-margin)] + [size (pt line-wrap-size printable-height)])) + (define page-qs (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) - (struct-copy quad q:section [elems page-qs]))) + (struct-copy quad q:section [elems page-qs]))) (define doc (time-log position (position (struct-copy quad q:doc [elems sections])))) (time-log draw (draw doc (current-pdf))))