From b5f794014e0ccf5573a45f219f95d933a41ccec4 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 13 May 2022 12:42:06 -0700 Subject: [PATCH] print-pass --- quad2/layout.rkt | 1 - quad2/main.rkt | 80 +++++++++++++++++++++++----------------------- quad2/pipeline.rkt | 49 ++++++++++++++++------------ 3 files changed, 69 insertions(+), 61 deletions(-) diff --git a/quad2/layout.rkt b/quad2/layout.rkt index 7d129a6d..4eb20da4 100644 --- a/quad2/layout.rkt +++ b/quad2/layout.rkt @@ -53,7 +53,6 @@ (for/fold ([posn0 ($point 0 0)] #:result qs) ([q (in-list qs)]) - #RRR q (define first-posn-on-next-line ($point 0 (add1 ($point-y posn0)))) (define other-possible-posns (list first-posn-on-next-line)) (define posn1 (for/first ([posn (in-list (cons posn0 other-possible-posns))] diff --git a/quad2/main.rkt b/quad2/main.rkt index 7ed36914..f9718755 100644 --- a/quad2/main.rkt +++ b/quad2/main.rkt @@ -15,52 +15,52 @@ racket/file) (define quad-compile - (make-pipeline (list - ;; each pass in the pipeline is at least - ;; (list-of quad?) -> (list-of quad?) + (make-pipeline + ;; each pass in the pipeline is at least + ;; (list-of quad?) -> (list-of quad?) - ;; attribute prep ============= - ;; all attrs start out as symbol-string pairs. - ;; we convert keys & values to corresponding higher-level types. - upgrade-attr-keys - downcase-string-attr-values - convert-boolean-attr-values - convert-numeric-attr-values - convert-set-attr-values - convert-path-attr-values + ;; attribute prep ============= + ;; all attrs start out as symbol-string pairs. + ;; we convert keys & values to corresponding higher-level types. + upgrade-attr-keys + downcase-string-attr-values + convert-boolean-attr-values + convert-numeric-attr-values + convert-set-attr-values + convert-path-attr-values - ;; wrap default values around top level - set-top-level-attr-values + ;; wrap default values around top level + set-top-level-attr-values - ;; pre-linearization resolutions & parsings ============= - ;; these need the tree shape - parse-dimension-strings - resolve-font-sizes - resolve-font-features - parse-page-sizes + ;; pre-linearization resolutions & parsings ============= + ;; these need the tree shape + parse-dimension-strings + resolve-font-sizes + resolve-font-features + parse-page-sizes - ;; linearization ============= - ;; we postpone this step until we're certain any - ;; information encoded from the hierarchy of quads - ;; has been absorbed into the attrs - ;; (e.g., cascading font sizes) - ;; because once we linearize, that information is gone. - linearize + ;; linearization ============= + ;; we postpone this step until we're certain any + ;; information encoded from the hierarchy of quads + ;; has been absorbed into the attrs + ;; (e.g., cascading font sizes) + ;; because once we linearize, that information is gone. + (print-pass linearize) - ;; post-linearization resolutions & parsings ============= - resolve-font-paths - complete-attr-paths + ;; post-linearization resolutions & parsings ============= + resolve-font-paths + complete-attr-paths - mark-text-runs - merge-adjacent-strings - split-whitespace - split-into-single-char-quads - fill-missing-font-path - remove-font-without-char - insert-fallback-font - layout - make-drawing-insts - stackify))) + mark-text-runs + merge-adjacent-strings + split-whitespace + split-into-single-char-quads + fill-missing-font-path + remove-font-without-char + insert-fallback-font + layout + make-drawing-insts + stackify)) (module+ main (require "render.rkt") diff --git a/quad2/pipeline.rkt b/quad2/pipeline.rkt index 81d6b219..74760421 100644 --- a/quad2/pipeline.rkt +++ b/quad2/pipeline.rkt @@ -6,7 +6,6 @@ (provide (all-defined-out)) (struct pipeline (passes) - #:constructor-name make-pipeline #:guard (λ (procs name) (unless ((list-of procedure?) procs) (raise-argument-error 'bad-input-to-compiler-constructor "list of procedures" procs)) @@ -22,6 +21,12 @@ (time (displayln pass) (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) (make-pipeline (append (pipeline-passes c) passes))) @@ -33,22 +38,26 @@ EXPRS ...) #`(define PASS-NAME (make-pipeline - (list - (procedure-rename - #,(syntax/loc stx - (λ (ARG) - (when (current-use-preconditions?) - (unless (PRECOND-PROC ARG) - (raise-argument-error 'PASS-NAME (format "~a (as precondition)" 'PRECOND-PROC) ARG))) - ;; a pass can be functional or mutational. - ;; if it returns void, assume mutational - ;; and return the input item. - (define res (match (let () EXPRS ...) - [(? void?) ARG] - [val val])) - (begin0 - res - (when (current-use-postconditions?) - (unless (POSTCOND-PROC res) - (raise-argument-error 'PASS-NAME (format "~a (as postcondition)" 'POSTCOND-PROC) res)))))) - 'PASS-NAME))))])) \ No newline at end of file + (procedure-rename + #,(syntax/loc stx + (λ (ARG) + (when (current-use-preconditions?) + (unless (PRECOND-PROC ARG) + (raise-argument-error 'PASS-NAME (format "~a (as precondition)" 'PRECOND-PROC) ARG))) + ;; a pass can be functional or mutational. + ;; if it returns void, assume mutational + ;; and return the input item. + (define res (match (let () EXPRS ...) + [(? void?) ARG] + [val val])) + (begin0 + res + (when (current-use-postconditions?) + (unless (POSTCOND-PROC res) + (raise-argument-error 'PASS-NAME (format "~a (as postcondition)" 'POSTCOND-PROC) res)))))) + 'PASS-NAME)))])) + +(define-pass (pass-printer qs) + #:pre values + #:post values + (for-each println qs)) \ No newline at end of file