let's get stricter

quad2/render.rkt

@@ -5,16 +5,54 @@
          txexpr)
 (provide (all-defined-out))
 
-(struct $renderer (doc-start-func
+(module inner racket/base
-                   doc-end-func
+  (provide (all-defined-out))
-                   page-start-func
+  (struct $renderer (doc-start-func
-                   page-end-func
+                     doc-end-func
-                   text-func
+                     page-start-func
-                   set-font-func
+                     page-end-func
-                   move-func
+                     text-func
-                   return-func) #:transparent)
+                     set-font-func
+                     move-func
+                     return-func) #:transparent)
 
-(define current-renderer (make-parameter ($renderer void void void void void void void void)))
+  (define-syntax-rule (check-arity PROCNAME [PROC ARITY] ...)
+    (begin
+      (unless (or (eq? (procedure-arity PROC) ARITY) (equal? void PROC))
+        (raise-argument-error PROCNAME (format "procedure of arity ~a for ~a" ARITY 'PROC) PROC)) ...))
+
+  (define (make-renderer
+           #:doc-start-func [doc-start-func void]
+           #:doc-end-func [doc-end-func void]
+           #:page-start-func [page-start-func void]
+           #:page-end-func [page-end-func void]
+           #:text-func [text-func void]
+           #:set-font-func [set-font-func void]
+           #:move-func [move-func void]
+           #:return-func [return-func void])
+    (check-arity 'make-renderer
+                 [doc-start-func 0]
+                 [doc-end-func 0]
+                 [page-start-func 2]
+                 [page-end-func 0]
+                 [text-func 1]
+                 [set-font-func 1]
+                 [move-func 2]
+                 [return-func 0])
+    ($renderer doc-start-func
+               doc-end-func
+               page-start-func
+               page-end-func
+               text-func
+               set-font-func
+               move-func
+               return-func)))
+
+(require 'inner)
+
+(define null-renderer (make-renderer))
+
+(define current-renderer (make-parameter null-renderer))
 
 (define text-renderer
   ;; scan over the instructions and record where the chars want to go
@@ -23,12 +61,12 @@
         [xmax 0]
         [ymax 0]
         [results null])
-    ($renderer
+    (make-renderer
-     void
+     #:page-start-func
-     void
      (λ (width height)
        (set! xmax width)
        (set! ymax height))
+     #:page-end-func
      (λ ()
        ;; fill in a character grid
        (define str (string-join
@@ -38,13 +76,12 @@
                             (for/list ([x (in-range xmax)])
                               (hash-ref char-pos-table (make-rectangular x y) (char->integer #\space)))))) "\n"))
        (set! results (cons str results)))
-     (λ (str) (hash-set! char-pos-table current-loc str))
+     #:text-func (λ (str) (hash-set! char-pos-table current-loc str))
-     void
+     #:move-func (λ (x y) (set! current-loc (make-rectangular x y)))
-     (λ (x y) (set! current-loc (make-rectangular x y)))
+     #:return-func (λ ()
-     (λ ()
+                     #;(unless (pair? results)
-       #;(unless (pair? results)
+                         (error 'text-renderer-failed))
-           (error 'text-renderer-failed))
+                     (for-each displayln results)))))
-       (for-each displayln results)))))
 
 (require racket/gui)
 
@@ -54,9 +91,8 @@
         [dc #f]
         [current-loc 0+0i]
         [current-font #false])
-    ($renderer
+    (make-renderer
-     void
+     #:page-start-func
-     void
      (let ([my-face (match (get-face-list 'mono)
                       [(? null?) (error 'no-mono-font-available)]
                       [(cons face _) face])])
@@ -66,10 +102,11 @@
          (set! dc (new bitmap-dc% [bitmap target]))
          (send dc set-font (make-font #:size 1 #:face my-face))
          (send dc set-text-foreground "black")))
-     void
+     #:text-func
      (λ (charint)
        (when dc
          (send dc draw-text (string (integer->char charint)) (real-part current-loc) (imag-part current-loc))))
+     #:set-font-func
      (λ (ps)
        ;; racket/draw can't load arbitrary user fonts from a path
        ;; https://github.com/racket/racket/issues/1348
@@ -78,7 +115,9 @@
        ;; but it would allow slightly more accurate rendering for contexts
        ;; that don't support fonts by path
        (log-quad2-warning (format "can't load font ~a" ps)))
+     #:move-func
      (λ (x y) (set! current-loc (make-rectangular x y)))
+     #:return-func
      (λ () (for-each displayln (map (λ (target) (make-object image-snip% target)) targets))))))
 
 (define (html-renderer html-file)
@@ -89,24 +128,28 @@
         [pages null]
         [fonts (make-hasheqv)]
         [current-font ""])
-    ($renderer
+    (make-renderer
-     void
+     #:page-start-func
-     void
      (λ (width height)
        (set! page-quads null)
        (set! xmax width)
        (set! ymax height))
+     #:page-end-func
      (λ ()
        (set! pages (cons `(div ((class "page")
                                 (style ,(format "position: relative;width:~apx;height:~apx;border:1px solid black;background:white" xmax ymax))) ,@(reverse page-quads)) pages))
        (set! page-quads null))
+     #:text-func
      (λ (charint)
        (set! page-quads (cons
                          `(div ((style ,(format "position: absolute;left:~apx;top:~apx;font-family:~a;font-size:~apx" (real-part current-loc) (imag-part current-loc) current-font 12)))
                                ,(string (integer->char charint))) page-quads)))
+     #:set-font-func
      (λ (ps)
        (set! current-font (hash-ref! fonts ps (λ () (gensym 'font)))))
+     #:move-func
      (λ (x y) (set! current-loc (make-rectangular x y)))
+     #:return-func
      (λ ()
        (with-output-to-file html-file
          #:exists 'replace