|
|
|
@ -34,9 +34,9 @@
|
|
|
|
|
(provide (all-defined-out))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (setup-pdf-path pdf-path-arg)
|
|
|
|
|
(define (setup-pdf-path pdf-path-arg replace-existing-file?)
|
|
|
|
|
;; convert pathlike arg into nice complete path.
|
|
|
|
|
(define pdf-path
|
|
|
|
|
(path->complete-path
|
|
|
|
|
(simplify-path
|
|
|
|
|
(expand-user-path
|
|
|
|
@ -46,6 +46,10 @@
|
|
|
|
|
;; so we use a temp path to write the file, and we'll delete it later.
|
|
|
|
|
[#false (build-path (find-system-path 'temp-dir) "quadwriter-temp.pdf")]
|
|
|
|
|
[path path]))))))
|
|
|
|
|
(unless replace-existing-file?
|
|
|
|
|
(when (file-exists? pdf-path)
|
|
|
|
|
(raise-argument-error 'render-pdf "path that doesn't exist" pdf-path)))
|
|
|
|
|
pdf-path)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (handle-hyphenate q)
|
|
|
|
@ -168,18 +172,15 @@
|
|
|
|
|
(hash-set! (current-named-quads) (get-define-val (car dq-group)) dq-group))
|
|
|
|
|
not-dqs)
|
|
|
|
|
|
|
|
|
|
(define default-line-height-multiplier 1.42)
|
|
|
|
|
(define (setup-qs qx-arg base-dir)
|
|
|
|
|
;; convert our input Q-expression into a useful form.
|
|
|
|
|
|
|
|
|
|
;; some typographic niceties
|
|
|
|
|
(define qexpr
|
|
|
|
|
(let ([qx (decode qx-arg
|
|
|
|
|
(define (insert-typographic-niceties qx-arg)
|
|
|
|
|
(decode qx-arg
|
|
|
|
|
#:string-proc (compose1 smart-ellipses smart-dashes)
|
|
|
|
|
#:txexpr-proc smart-quotes)])
|
|
|
|
|
#:txexpr-proc smart-quotes))
|
|
|
|
|
|
|
|
|
|
(define (insert-dummy-element qx)
|
|
|
|
|
(match qx
|
|
|
|
|
[(txexpr tag attrs elements)
|
|
|
|
|
;; we insert a dummy quad '(q ".")
|
|
|
|
|
;; we insert a dummy element "."
|
|
|
|
|
;; (could be anything, but we want to use something obvious
|
|
|
|
|
;; so we don't trigger a fallback font)
|
|
|
|
|
;; to get a sample of the global attrs
|
|
|
|
@ -187,31 +188,47 @@
|
|
|
|
|
;; but keep the attrs around in case anyone needs to use them
|
|
|
|
|
;; for instance, quads added to the layout like footers
|
|
|
|
|
;; won't have another way of getting this
|
|
|
|
|
(list* tag attrs (cons '(q ".") elements))])))
|
|
|
|
|
(list* tag attrs (cons "." elements))]))
|
|
|
|
|
|
|
|
|
|
(define (apply-default-styling-attributes qexpr)
|
|
|
|
|
;; apply some default styling attributes.
|
|
|
|
|
;; These will only be used if the underlying q-expression hasn't specified its own values,
|
|
|
|
|
;; which will naturally override these.
|
|
|
|
|
(define q
|
|
|
|
|
(qexpr->quad (list 'q (list->attrs
|
|
|
|
|
:font-family default-font-family
|
|
|
|
|
:font-size (number->string default-font-size)
|
|
|
|
|
:font-features default-font-features
|
|
|
|
|
:hyphenate "true"
|
|
|
|
|
:line-height (number->string (floor (* default-line-height-multiplier default-font-size)))) qexpr)))
|
|
|
|
|
(setup-font-path-table! base-dir)
|
|
|
|
|
(let* ([qs (atomize q
|
|
|
|
|
:line-height
|
|
|
|
|
(number->string (floor (* default-line-height-multiplier default-font-size)))) qexpr)))
|
|
|
|
|
|
|
|
|
|
(define (make-atomic-qs q)
|
|
|
|
|
(atomize q
|
|
|
|
|
#:attrs-proc handle-cascading-attrs
|
|
|
|
|
#:missing-glyph-action 'fallback
|
|
|
|
|
#:fallback "fallback"
|
|
|
|
|
#:emoji "fallback-emoji"
|
|
|
|
|
#:math "fallback-math"
|
|
|
|
|
#:font-path-resolver resolve-font-path!)]
|
|
|
|
|
[qs (let ()
|
|
|
|
|
;; store the dummy element and discard
|
|
|
|
|
#:font-path-resolver resolve-font-path!))
|
|
|
|
|
|
|
|
|
|
(define (store-dummy-element-and-discard qs)
|
|
|
|
|
(current-top-level-quad (car qs))
|
|
|
|
|
(cdr qs))]
|
|
|
|
|
[qs (time-log hyphenate (apply append (map handle-hyphenate qs)))]
|
|
|
|
|
(cdr qs))
|
|
|
|
|
|
|
|
|
|
(define (apply-hyphenation qs)
|
|
|
|
|
(time-log hyphenate (apply append (map handle-hyphenate qs))))
|
|
|
|
|
|
|
|
|
|
(define default-line-height-multiplier 1.42)
|
|
|
|
|
(define (setup-qs qx-arg [base-dir (current-directory)])
|
|
|
|
|
;; convert our input Q-expression into a useful form.
|
|
|
|
|
|
|
|
|
|
(setup-font-path-table! base-dir)
|
|
|
|
|
(let* ([qx (insert-typographic-niceties qx-arg)]
|
|
|
|
|
[qexpr (insert-dummy-element qx)]
|
|
|
|
|
[q (apply-default-styling-attributes qexpr)]
|
|
|
|
|
[qs (make-atomic-qs q)]
|
|
|
|
|
[qs (store-dummy-element-and-discard qs)]
|
|
|
|
|
[qs (apply-hyphenation qs)]
|
|
|
|
|
[qs (map generic->typed-quad qs)]
|
|
|
|
|
[qs (drop-leading-breaks qs)]
|
|
|
|
|
#;[qs (extract-defined-quads qs)]
|
|
|
|
@ -265,7 +282,7 @@
|
|
|
|
|
(define (setup-column-gap qs)
|
|
|
|
|
(or (debug-column-gap) (quad-ref (car qs) :column-gap default-column-gap)))
|
|
|
|
|
|
|
|
|
|
(define (setup-pdf-metadata! qs pdf)
|
|
|
|
|
(define (setup-pdf-metadata! pdf qs)
|
|
|
|
|
(define kv-dict
|
|
|
|
|
(cons
|
|
|
|
|
(cons 'Creator (format "Racket ~a [Quad ~a]" (version) (pkg-checksum "quad" #:short #true)))
|
|
|
|
@ -306,9 +323,10 @@
|
|
|
|
|
[size (pt line-wrap-size printable-height)]))
|
|
|
|
|
(time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype)))
|
|
|
|
|
|
|
|
|
|
(define (layout qs)
|
|
|
|
|
(quad-update! q:doc [elems (make-sections qs)]))
|
|
|
|
|
|
|
|
|
|
(define (make-sections all-qs)
|
|
|
|
|
|
|
|
|
|
(for/fold ([sections-acc null]
|
|
|
|
|
#:result (reverse sections-acc))
|
|
|
|
|
([qs (in-list (filter-split all-qs section-break-quad?))])
|
|
|
|
@ -449,6 +467,33 @@
|
|
|
|
|
[(quad? x) (for-each loop (quad-elems x))])))
|
|
|
|
|
doc)
|
|
|
|
|
|
|
|
|
|
(define (setup-base-dir base-dir-arg pdf-path-arg)
|
|
|
|
|
(define maybe-dir (cond
|
|
|
|
|
;; for reasons unclear, DrRacket sometimes sneaks
|
|
|
|
|
;; an "unsaved editor" into base-dir-arg, despite efforts
|
|
|
|
|
;; probably my fault
|
|
|
|
|
[(equal? base-dir-arg "unsaved editor") pdf-path-arg]
|
|
|
|
|
[base-dir-arg]
|
|
|
|
|
[pdf-path-arg]
|
|
|
|
|
[else (current-directory)]))
|
|
|
|
|
(define base-dir (match maybe-dir
|
|
|
|
|
[(? directory-exists? dir) dir]
|
|
|
|
|
[(app path->complete-path cp)
|
|
|
|
|
(define-values (dir name _) (split-path cp))
|
|
|
|
|
dir]))
|
|
|
|
|
(unless (directory-exists? base-dir)
|
|
|
|
|
(raise-argument-error 'render-pdf "existing directory" base-dir))
|
|
|
|
|
base-dir)
|
|
|
|
|
|
|
|
|
|
(define (log-completion)
|
|
|
|
|
(log-quadwriter-info (format "wrote PDF to ~a" (pdf-output-path (current-pdf)))))
|
|
|
|
|
|
|
|
|
|
(define (return-pdf-bytes pdf-path-arg)
|
|
|
|
|
(define pdf-path (pdf-output-path (current-pdf)))
|
|
|
|
|
(begin0
|
|
|
|
|
(file->bytes pdf-path)
|
|
|
|
|
(delete-file pdf-path)))
|
|
|
|
|
|
|
|
|
|
(define/contract (render-pdf qx-arg
|
|
|
|
|
[pdf-path-arg #false]
|
|
|
|
|
[base-dir-arg #false]
|
|
|
|
@ -465,59 +510,28 @@
|
|
|
|
|
;; `base-dir-arg` is the starting point for resolving any relative pathnames,
|
|
|
|
|
;; and looking for fonts and other assets.
|
|
|
|
|
|
|
|
|
|
(define base-dir (let ([maybe-dir (cond
|
|
|
|
|
;; for reasons unclear, DrRacket sometimes sneaks
|
|
|
|
|
;; an "unsaved editor" into base-dir-arg, despite efforts
|
|
|
|
|
;; probably my fault
|
|
|
|
|
[(equal? base-dir-arg "unsaved editor") pdf-path-arg]
|
|
|
|
|
[base-dir-arg]
|
|
|
|
|
[pdf-path-arg]
|
|
|
|
|
[else (current-directory)])])
|
|
|
|
|
(match maybe-dir
|
|
|
|
|
[(? directory-exists? dir) dir]
|
|
|
|
|
[(app path->complete-path cp)
|
|
|
|
|
(define-values (dir name _) (split-path cp))
|
|
|
|
|
dir])))
|
|
|
|
|
|
|
|
|
|
(unless (directory-exists? base-dir)
|
|
|
|
|
(raise-argument-error 'render-pdf "existing directory" base-dir))
|
|
|
|
|
|
|
|
|
|
(define pdf-path (setup-pdf-path pdf-path-arg))
|
|
|
|
|
(unless replace-existing-file?
|
|
|
|
|
(when (file-exists? pdf-path)
|
|
|
|
|
(raise-argument-error 'render-pdf "path that doesn't exist" pdf-path)))
|
|
|
|
|
|
|
|
|
|
;; `make-pdf` creates a PDF data structure using the pitfall library.
|
|
|
|
|
;; this structure provides some services as we lay out the document,
|
|
|
|
|
;; and then when we render, we'll rely on pitfall's PDF-drawing routines.
|
|
|
|
|
(parameterize ([current-pdf (make-pdf #:compress compress?
|
|
|
|
|
(parameterize ([current-pdf
|
|
|
|
|
(make-pdf #:compress compress?
|
|
|
|
|
#:auto-first-page #false
|
|
|
|
|
#:output-path pdf-path)]
|
|
|
|
|
#:output-path (setup-pdf-path pdf-path-arg replace-existing-file?))]
|
|
|
|
|
;; set `current-directory` so that ops like `path->complete-path`
|
|
|
|
|
;; will be handled relative to the original directory
|
|
|
|
|
[current-directory base-dir]
|
|
|
|
|
[current-directory (setup-base-dir base-dir-arg pdf-path-arg)]
|
|
|
|
|
;; a lot of operations need to look at pages used so it's easier to
|
|
|
|
|
;; make it a parameter than endlessly pass it around as an argument.
|
|
|
|
|
[section-pages-used 0]
|
|
|
|
|
[verbose-quad-printing? #false]
|
|
|
|
|
#;[current-named-quads (make-hash)]) ; for ease of debugging; not mandatory
|
|
|
|
|
(define qs (time-log setup-qs (setup-qs qx-arg base-dir)))
|
|
|
|
|
(setup-pdf-metadata! qs (current-pdf))
|
|
|
|
|
;; all the heavy lifting happens inside `make-sections`
|
|
|
|
|
;; which calls out to `make-pages`, `make-columns`, and so on.
|
|
|
|
|
|
|
|
|
|
(define doc (let ([doc (quad-update! q:doc [elems (make-sections qs)])])
|
|
|
|
|
(time-log prep-doc (let* ([doc (correct-line-alignment doc)]
|
|
|
|
|
(let* ([qs (time-log setup-qs (setup-qs qx-arg))]
|
|
|
|
|
[_ (setup-pdf-metadata! (current-pdf) qs)]
|
|
|
|
|
;; all the heavy lifting happens inside `layout`
|
|
|
|
|
[doc (layout qs)]
|
|
|
|
|
[doc (correct-line-alignment doc)]
|
|
|
|
|
[doc (resolve-repeaters doc)]
|
|
|
|
|
[doc (resolve-parents doc)])
|
|
|
|
|
doc))))
|
|
|
|
|
;; call `position` and `draw` separately so we can print a timer for each
|
|
|
|
|
(define positioned-doc (time-log position (position doc)))
|
|
|
|
|
;; drawing implies that a PDF is written to disk
|
|
|
|
|
(time-log draw (draw positioned-doc (current-pdf))))
|
|
|
|
|
|
|
|
|
|
(if pdf-path-arg
|
|
|
|
|
(log-quadwriter-info (format "wrote PDF to ~a" pdf-path))
|
|
|
|
|
(begin0
|
|
|
|
|
(file->bytes pdf-path)
|
|
|
|
|
(delete-file pdf-path))))
|
|
|
|
|
[doc (resolve-parents doc)]
|
|
|
|
|
[positioned-doc (position doc)]
|
|
|
|
|
[_ (draw positioned-doc (current-pdf))])
|
|
|
|
|
(if pdf-path-arg (log-completion) (return-pdf-bytes)))))
|
|
|
|
|