another toe

fontland/fontland/font.rkt

@@ -25,20 +25,22 @@
          sugar/list
          racket/promise
          crc32c)
-(provide (all-defined-out))
+(provide (except-out (all-defined-out) 
+   head
+   post
+   hhea
+   maxp
+   OS/2
+   cvt_
+   prep
+   fpgm))
 
 #|
 approximates
 https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 |#
 
-(require (for-syntax "tables.rkt"))
-(define-syntax (define-table-getters stx)
-  (syntax-case stx ()
-    [(_)
-     (with-syntax ([(TABLE-TAG ...) (hash-keys table-codecs)])
-       #'(begin
-           (define/public (TABLE-TAG) (_getTable 'TABLE-TAG)) ...))]))
+
 
 
 (test-module
@@ -68,28 +70,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
          [_hb-buf (delay (hb_buffer_create))]
          [_crc (begin0 (crc32c-input-port _port) (pos _port 0))])
 
-
-  (define/public (_getTable table-tag)
-    (unless (has-table? this table-tag)
-      (raise-argument-error '_getTable "table that exists in font" table-tag))
-    (hash-ref! _decoded-tables table-tag (λ () (_decodeTable table-tag))))
-
-  (define-table-getters)
-
-  (define/public (_getTableStream tag)
-    (define table (hash-ref (· this directory tables) tag))
-    (and table (pos _port (· table offset)) _port))
-  
-  (define/public (_decodeTable table-tag)
-    (unless (hash-has-key? table-codecs table-tag)
-      (raise-argument-error '_decodeTable "decodable table" table-tag))
-    (define table (hash-ref (· this directory tables) table-tag))
-    ;; todo: possible to avoid copying the bytes here?
-    (pos _port (· table offset))
-    (define table-bytes (open-input-bytes (peek-bytes (· table length) 0 _port)))
-    (define table-decoder (hash-ref table-codecs table-tag))
-    (decode table-decoder table-bytes #:parent this))
-
   (as-methods
    postscriptName
    measure-string
@@ -104,11 +84,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
    xHeight
    bbox
    createSubset
-   has-table?
-   has-cff-table?
-   has-morx-table?
-   has-gsub-table?
-   has-gpos-table?
    getGlyph
    layout
    glyphsForString
@@ -116,7 +91,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
    directory
    ft-face
    hb-font
-   hb-buf))
+   hb-buf
+   head
+   post
+   hhea
+   maxp
+   OS/2
+   cvt_
+   prep
+   fpgm))
 
 
   (define (directory this) (force (· this _directory)))
@@ -124,6 +107,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
   (define (hb-font this) (or (force (· this _hb-font)) (error 'hb-font-not-available)))
   (define (hb-buf this) (force (· this _hb-buf)))
 
+(require "table-stream.rkt")
+(define (head this) (_getTable this 'head))
+(define (post this) (_getTable this 'post))
+(define (hhea this) (_getTable this 'hhea))
+(define (OS/2 this) (_getTable this 'OS/2))
+(define (maxp this) (_getTable this 'maxp))
+(define (cvt_ this) (_getTable this 'cvt_))
+(define (prep this) (_getTable this 'prep))
+(define (fpgm this) (_getTable this 'fpgm))
 
 ;; The unique PostScript name for this font
 (define/contract (postscriptName this)
@@ -193,7 +185,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 ;; The height of capital letters above the baseline.
 (define/contract (capHeight this)
   (->m number?)
-  (if (send this has-table? #"OS/2")
+  (if (has-table? this #"OS/2")
       (· this OS/2 capHeight)
       (· this ascent)))
 
@@ -204,7 +196,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
 ;; The height of lower case letters in the font.
 (define/contract (xHeight this)
   (->m number?)
-  (if (send this has-table? #"OS/2")
+  (if (has-table? this #"OS/2")
       (· this OS/2 xHeight)
       0))
 
@@ -230,24 +222,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js
   (+ttf-subset this))
 
 
-(define/contract (has-table? this tag)
-  ((or/c bytes? symbol?) . ->m . boolean?)
-  (hash-has-key? (· this directory tables) (match tag
-                                             [(? bytes?) (string->symbol (bytes->string/latin-1 tag))]
-                                             [_ tag])))
-  
-(define (has-cff-table? x) (has-table? x 'CFF_))
-(define (has-morx-table? x) (has-table? x 'morx))
-(define (has-gpos-table? x) (has-table? x 'GPOS))
-(define (has-gsub-table? x) (has-table? x 'GSUB))
-
-(test-module
- (check-false (· f has-cff-table?))
- (check-false (· f has-morx-table?))
- (check-false (· f has-gsub-table?))
- (check-false (· f has-gpos-table?)))
-
-
 ;; Returns a glyph object for the given glyph id.
 ;; You can pass the array of code points this glyph represents for
 ;; your use later, and it will be stored in the glyph object.
@@ -418,8 +392,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/base.js
 
 (test-module
  (check-equal? (measure-string f "f" (· f unitsPerEm)) 321.0)
- (check-true (send f has-table? #"cmap"))
- (check-exn exn:fail:contract? (λ () (send f _getTable 'nonexistent-table-tag)))
+ (check-true (has-table? f #"cmap"))
+ (check-exn exn:fail:contract? (λ () (_getTable f 'nonexistent-table-tag)))
  (check-true
   (let ([h (layout fira "Rifle" #:debug #t)])
     (and (equal? (hash-ref h 'hb-gids) '(227 480 732 412))

fontland/fontland/subset.rkt

@@ -6,6 +6,7 @@
          sugar/unstable/dict
          sugar/unstable/js
          "table/loca.rkt"
+         "table-stream.rkt"
          "directory.rkt"
          fontland/glyph
          fontland/ttf-glyph
@@ -71,9 +72,9 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
   (define ttf-glyf-data (glyph-decode glyph))
 
   ;; get the offset to the glyph from the loca table
-  (match-define (list this-offset next-offset) (take (drop (· (subset-font ss) loca offsets) gid) 2))
+  (match-define (list this-offset next-offset) (take (drop (hash-ref (dump (_getTable (subset-font ss) 'loca)) 'offsets) gid) 2))
 
-  (define port (send (subset-font ss) _getTableStream 'glyf))
+  (define port (_getTableStream (subset-font ss) 'glyf))
   (pos port (+ (pos port) this-offset))
 
   (define buffer (read-bytes  (- next-offset this-offset) port))
@@ -105,6 +106,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
 
 (define (clone-deep val)  (deserialize (serialize val)))
 
+(require racket/sequence)
 (define (encode ss port)
   #;(output-port? . ->m . void?)
   
@@ -134,23 +136,29 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js
   (define hhea (clone-deep (· (subset-font ss) hhea to-hash)))
   (dict-set! hhea 'numberOfMetrics (length (· (ttf-subset-hmtx ss) metrics)))
 
+  (define table-mhash
+    (let ([mh (make-hasheq)])
+      (define kvs (list 'head head
+                        'hhea hhea
+                        'loca (ttf-subset-loca ss)
+                        'maxp maxp
+                        'cvt_ (· (subset-font ss) cvt_)
+                        'prep (· (subset-font ss) prep)
+                        'glyf (ttf-subset-glyf ss)
+                        'hmtx (ttf-subset-hmtx ss)
+                        'fpgm (· (subset-font ss) fpgm)))
+      (for ([kv (in-slice 2 kvs)])
+        (unless (second kv)
+          (error 'encode (format "missing value for ~a" (first kv))))
+        (hash-set! mh (first kv) (second kv)))
+      mh))
   
-  (send Directory encode port
-        (mhash 'tables
-               (mhash
-                'head head
-                'hhea hhea
-                'loca (ttf-subset-loca ss)
-                'maxp maxp
-                'cvt_ (· (subset-font ss) cvt_)
-                'prep (· (subset-font ss) prep)
-                'glyf (ttf-subset-glyf ss)
-                'hmtx (ttf-subset-hmtx ss)
-                'fpgm (· (subset-font ss) fpgm))))
-
-  #;(report* (bytes-length (send stream dump)) (send stream dump))
-  #;(report* (bytes-length (file->bytes "out.bin")) (file->bytes "out.bin"))
+    (send Directory encode port (mhash 'tables table-mhash))
+
+    #;(report* (bytes-length (send stream dump)) (send stream dump))
+    #;(report* (bytes-length (file->bytes "out.bin")) (file->bytes "out.bin"))
   
-  (void)
-  )
+    (void)
+    )
 
+  

fontland/fontland/table-stream.rkt

@@ -0,0 +1,43 @@
+#lang racket
+(require sugar/unstable/js
+         (only-in xenomorph pos decode)
+         "tables.rkt"
+         (for-syntax "tables.rkt"))
+(provide (all-defined-out))
+
+(define-syntax (define-table-getters stx)
+  (syntax-case stx ()
+    [(_)
+     (with-syntax ([(TABLE-TAG ...) (hash-keys table-codecs)])
+       #'(begin
+           (define (TABLE-TAG this) (_getTable this 'TABLE-TAG)) ...))]))
+
+(define (has-table? this tag)
+  #;((or/c bytes? symbol?) . ->m . boolean?)
+  (hash-has-key? (· this directory tables) (match tag
+                                             [(? bytes?) (string->symbol (bytes->string/latin-1 tag))]
+                                             [_ tag])))
+  
+
+
+(define (_getTable this table-tag)
+  (unless (has-table? this table-tag)
+    (raise-argument-error '_getTable "table that exists in font" table-tag))
+  (hash-ref! (· this  _decoded-tables) table-tag (λ () (_decodeTable this table-tag))))
+
+(define-table-getters)
+
+(define (_getTableStream this tag)
+  (define table (hash-ref (· this directory tables) tag))
+  (and table (pos (· this _port) (· table offset)) (· this _port)))
+  
+(define  (_decodeTable this table-tag)
+  (unless (hash-has-key? table-codecs table-tag)
+    (raise-argument-error '_decodeTable "decodable table" table-tag))
+  (define table (hash-ref (· this directory tables) table-tag))
+  ;; todo: possible to avoid copying the bytes here?
+  (pos (· this _port) (· table offset))
+  (define table-bytes (open-input-bytes (peek-bytes (· table length) 0 (· this _port))))
+  (define table-decoder (hash-ref table-codecs table-tag))
+  (decode table-decoder table-bytes #:parent this))
+

fontland/fontland/ttf-glyph.rkt

@@ -1,4 +1,4 @@
-#lang racket/base
+#lang debug racket/base
 (require (for-syntax racket/base)
          racket/match
          racket/list
@@ -101,14 +101,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/glyph/TTFGlyph.js
 
 ;; Decodes the glyph data into points for simple glyphs,
 ;; or components for composite glyphs
+(require "table-stream.rkt")
 (define (glyph-decode ttfg)
-  (define offsets (· (glyph-font ttfg) loca offsets))
+  (define offsets (hash-ref (dump (_getTable (glyph-font ttfg) 'loca)) 'offsets))
   (match-define (list glyfPos nextPos) (take (drop offsets (glyph-id ttfg)) 2))
 
   ;; Nothing to do if there is no data for this glyph
   (and (not (= glyfPos nextPos))
        (let ()
-         (define port (send (glyph-font ttfg) _getTableStream 'glyf))
+         (define port (_getTableStream (glyph-font ttfg) 'glyf))
          (pos port (+ (pos port) glyfPos))
          (define startPos (pos port))
          (define glyph-data (decode GlyfHeader port))