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

print-pass

Browse Source
main
Matthew Butterick 2 years ago
parent 2cc67cd3bf
commit b5f794014e
3 changed files with 69 additions and 61 deletions
Show Stats Download Patch File Download Diff File

1
quad2/layout.rkt
Unescape Escape View File

@ -53,7 +53,6 @@
(for/fold ([posn0 ($point 0 0)] (for/fold ([posn0 ($point 0 0)]
#:result qs) #:result qs)
([q (in-list qs)]) ([q (in-list qs)])
#RRR q
(define first-posn-on-next-line ($point 0 (add1 ($point-y posn0)))) (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0))))
(define other-possible-posns (list first-posn-on-next-line)) (define other-possible-posns (list first-posn-on-next-line))
(define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))] (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))]

80
quad2/main.rkt
Unescape Escape View File

@ -15,52 +15,52 @@
racket/file) racket/file)
(define quad-compile (define quad-compile
(make-pipeline (list (make-pipeline
;; each pass in the pipeline is at least ;; each pass in the pipeline is at least
;; (list-of quad?) -> (list-of quad?) ;; (list-of quad?) -> (list-of quad?)
;; attribute prep ============= ;; attribute prep =============
;; all attrs start out as symbol-string pairs. ;; all attrs start out as symbol-string pairs.
;; we convert keys & values to corresponding higher-level types. ;; we convert keys & values to corresponding higher-level types.
upgrade-attr-keys upgrade-attr-keys
downcase-string-attr-values downcase-string-attr-values
convert-boolean-attr-values convert-boolean-attr-values
convert-numeric-attr-values convert-numeric-attr-values
convert-set-attr-values convert-set-attr-values
convert-path-attr-values convert-path-attr-values
;; wrap default values around top level ;; wrap default values around top level
set-top-level-attr-values set-top-level-attr-values
;; pre-linearization resolutions & parsings ============= ;; pre-linearization resolutions & parsings =============
;; these need the tree shape ;; these need the tree shape
parse-dimension-strings parse-dimension-strings
resolve-font-sizes resolve-font-sizes
resolve-font-features resolve-font-features
parse-page-sizes parse-page-sizes
;; linearization ============= ;; linearization =============
;; we postpone this step until we're certain any ;; we postpone this step until we're certain any
;; information encoded from the hierarchy of quads ;; information encoded from the hierarchy of quads
;; has been absorbed into the attrs ;; has been absorbed into the attrs
;; (e.g., cascading font sizes) ;; (e.g., cascading font sizes)
;; because once we linearize, that information is gone. ;; because once we linearize, that information is gone.
linearize (print-pass linearize)
;; post-linearization resolutions & parsings ============= ;; post-linearization resolutions & parsings =============
resolve-font-paths resolve-font-paths
complete-attr-paths complete-attr-paths
mark-text-runs mark-text-runs
merge-adjacent-strings merge-adjacent-strings
split-whitespace split-whitespace
split-into-single-char-quads split-into-single-char-quads
fill-missing-font-path fill-missing-font-path
remove-font-without-char remove-font-without-char
insert-fallback-font insert-fallback-font
layout layout
make-drawing-insts make-drawing-insts
stackify))) stackify))
(module+ main (module+ main
(require "render.rkt") (require "render.rkt")

49
quad2/pipeline.rkt
Unescape Escape View File

@ -6,7 +6,6 @@
(provide (all-defined-out)) (provide (all-defined-out))
(struct pipeline (passes) (struct pipeline (passes)
#:constructor-name make-pipeline
#:guard (λ (procs name) #:guard (λ (procs name)
(unless ((list-of procedure?) procs) (unless ((list-of procedure?) procs)
(raise-argument-error 'bad-input-to-compiler-constructor "list of procedures" procs)) (raise-argument-error 'bad-input-to-compiler-constructor "list of procedures" procs))
@ -22,6 +21,12 @@
(time (displayln pass) (thunk)) (time (displayln pass) (thunk))
(thunk)))))) (thunk))))))
(define (make-pipeline . passes)
(pipeline passes))
(define (print-pass . passes)
(apply make-pipeline (append passes (list pass-printer))))
(define (compiler-append c passes) (define (compiler-append c passes)
(make-pipeline (append (pipeline-passes c) passes))) (make-pipeline (append (pipeline-passes c) passes)))
@ -33,22 +38,26 @@
EXPRS ...) EXPRS ...)
#`(define PASS-NAME #`(define PASS-NAME
(make-pipeline (make-pipeline
(list (procedure-rename
(procedure-rename #,(syntax/loc stx
#,(syntax/loc stx (λ (ARG)
(λ (ARG) (when (current-use-preconditions?)
(when (current-use-preconditions?) (unless (PRECOND-PROC ARG)
(unless (PRECOND-PROC ARG) (raise-argument-error 'PASS-NAME (format "~a (as precondition)" 'PRECOND-PROC) ARG)))
(raise-argument-error 'PASS-NAME (format "~a (as precondition)" 'PRECOND-PROC) ARG))) ;; a pass can be functional or mutational.
;; a pass can be functional or mutational. ;; if it returns void, assume mutational
;; if it returns void, assume mutational ;; and return the input item.
;; and return the input item. (define res (match (let () EXPRS ...)
(define res (match (let () EXPRS ...) [(? void?) ARG]
[(? void?) ARG] [val val]))
[val val])) (begin0
(begin0 res
res (when (current-use-postconditions?)
(when (current-use-postconditions?) (unless (POSTCOND-PROC res)
(unless (POSTCOND-PROC res) (raise-argument-error 'PASS-NAME (format "~a (as postcondition)" 'POSTCOND-PROC) res))))))
(raise-argument-error 'PASS-NAME (format "~a (as postcondition)" 'POSTCOND-PROC) res)))))) 'PASS-NAME)))]))
'PASS-NAME))))]))
(define-pass (pass-printer qs)
#:pre values
#:post values
(for-each println qs))
Write Preview
Loading…
Cancel
Save