print-pass

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))]

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")

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))))]))
+          (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))