simplify woffing

fontland/fontland/directory.rkt

@@ -55,7 +55,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
               'rangeShift (- (* numTables 16) searchRange))
   this-val)
 
-(define Directory (x:struct #:pre-encode directory-pre-encode
+(define directory (x:struct #:pre-encode directory-pre-encode
                             #:post-decode directory-post-decode
                             'tag (x:symbol #:length 4)
                             'numTables uint16be
@@ -65,7 +65,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
                             'tables (x:array #:type table-entry #:length (λ (p) (hash-ref p 'numTables)))))
 
 (define (directory-decode ip [options (mhash)])
-  (decode Directory ip))
+  (decode directory ip))
 
 (define (file-directory-decode ps)
   (directory-decode (open-input-file ps)))

fontland/fontland/font.rkt

@@ -27,23 +27,30 @@ approximates
 https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 |#
 
+(struct probe-fail exn ())
+
 (define (+ttf-font port
-                   [decoded-tables (mhash)]
-                   [src (path->string (object-name port))]
-                   [directory (delay (decode Directory port #:parent (mhash x:start-offset-key 0)))]
-                   [ft-face (delay (and src (FT_New_Face (force ft-library) src)))]
-                   [hb-font (delay (and src (hb_ft_font_create (force ft-face))))]
-                   [hb-buf (delay (hb_buffer_create))]
-                   [crc (equal-hash-code port)]
-                   [get-head-table-proc #f])
+                   #:directory [directory-class directory]
+                   #:probe [probe-vals (list #"true" #"OTTO" (bytes 0 1 0 0))])
+  
   (unless (input-port? port)
     (raise-argument-error '+ttf-font "input port" port))
-  (unless (member (peek-bytes 4 0 port) (list #"true" #"OTTO" (bytes 0 1 0 0)))
-    (do-probe-fail!))
+  (unless (member (peek-bytes 4 0 port) probe-vals)
+    (raise (probe-fail "fail" (current-continuation-marks))))
+  
+  (define decoded-tables (mhash))
+  (define src (path->string (object-name port)))
+  (define directory (delay (decode directory-class port #:parent (mhash x:start-offset-key 0))))
+  (define ft-face (delay (and src (FT_New_Face (force ft-library) src))))
+  (define hb-font (delay (and src (hb_ft_font_create (force ft-face)))))
+  (define hb-buf (delay (hb_buffer_create)))
+  (define crc (equal-hash-code port))
+  (define get-head-table-proc #f)
+ 
   (define font
     (ttf-font port decoded-tables src directory ft-face hb-font hb-buf crc get-head-table-proc))
   ;; needed for `loca` table decoding cross-reference
-  (set-ttf-font-get-head-table-proc! font (delay  (get-head-table font)))
+  (set-ttf-font-get-head-table-proc! font (delay (get-head-table font)))
   font)
 
 (define (font-postscript-name font) (FT_Get_Postscript_Name (ft-face font)))
@@ -76,24 +83,10 @@ approximates
 https://github.com/mbutterick/fontkit/blob/master/src/WOFFFont.js
 |#
 
-(define (+woff-font port
-                    [decoded-tables (mhash)]
-                    [src (path->string (object-name port))]
-                    [directory (delay (decode woff-directory port #:parent (mhash x:start-offset-key 0)))]
-                    [ft-face (delay (and src (FT_New_Face (force ft-library) src)))]
-                    [hb-font (delay (and src (hb_ft_font_create (force ft-face))))]
-                    [hb-buf (delay (hb_buffer_create))]
-                    [crc (equal-hash-code port)]
-                    [get-head-table-proc #f])
-  (unless (input-port? port)
-    (raise-argument-error '+woff-font "input port" port))
-  (unless (member (peek-bytes 4 0 port) (list #"wOFF"))
-    (do-probe-fail!))
-  (define font
-    (ttf-font port decoded-tables src directory ft-face hb-font hb-buf crc get-head-table-proc))
-  ;; needed for `loca` table decoding cross-reference
-  (set-ttf-font-get-head-table-proc! font (delay  (get-head-table font)))
-  font)
+(define (+woff-font port)
+  (+ttf-font port
+             #:directory woff-directory
+             #:probe (list #"wOFF")))
 
 ;; 181228: disk-based caching (either with sqlite or `with-cache`) is a loser
 ;; reads & writes aren't worth it vs. recomputing
@@ -152,10 +145,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/base.js
        (font-constructor port)))
    (error 'create-font "unknown font format")))
 
-(struct probe-fail exn ())
-(define (do-probe-fail!)
-  (raise (probe-fail "fail" (current-continuation-marks))))
-
 (module+ test
   (require rackunit racket/struct racket/vector)
   (define charter (open-font charter-path))

fontland/fontland/table-stream.rkt

@@ -37,9 +37,10 @@
   (define table (hash-ref (hash-ref directory 'tables) tag))
   (and table
        (pos (ttf-font-port this) (hash-ref table 'offset))
-       (if (< (hash-ref table 'compLength +inf.0) (hash-ref table 'length))
-           (open-input-bytes (inflate (peek-bytes (hash-ref table 'compLength) 0 (ttf-font-port this))))
-           (ttf-font-port this))))
+       (let ([maybe-woff-compLength (hash-ref table 'compLength #f)])
+         (if (and maybe-woff-compLength (< maybe-woff-compLength (hash-ref table 'length)))
+             (open-input-bytes (inflate (peek-bytes maybe-woff-compLength 0 (ttf-font-port this))))
+             (ttf-font-port this)))))
   
 (define (decode-table this table-tag)
   (unless (hash-has-key? table-codecs table-tag)