redo

pitfall/pitfall/fontkit.rkt

@@ -4,19 +4,22 @@
 
 (define-runtime-path charter-path "test/assets/charter.ttf")
 
-;; approximates
-;; https://github.com/devongovett/fontkit/blob/master/src/TTFFont.js
+#|
+approximates
+https://github.com/devongovett/fontkit/blob/master/src/TTFFont.js
+|#
 
 ;; This is the base class for all SFNT-based font formats in fontkit.
 ;;  It supports TrueType, and PostScript glyphs, and several color glyph formats.
-(define-subclass object% (TTFFont [stream (open-input-bytes #"")])
-  (super-new)
+(define-subclass object% (TTFFont stream)
   (when stream (unless (input-port? stream)
                  (raise-argument-error 'TTFFont "input port" stream)))
+  (unless (member (bytes->string/latin-1 (peek-bytes 4 0 stream))
+                  (list "true" "OTTO" "\u0\u1\u0\u0"))
+    (raise 'probe-fail))
   (port-count-lines! stream)
   ;; skip variationCoords
-  (field [_directoryPos (let-values ([(l c p) (port-next-location stream)])
-                          p)]
+  (field [_directoryPos (port-position stream)]
          [_tables (mhash)]
          [_glyphs (mhash)]
          [_layoutEngine #f])
@@ -37,13 +40,6 @@
   (define/public (_decodeDirectory)
     (set! directory (directory-decode stream (mhash '_startOffset 0)))
     directory)
-
-  (define/public (probe buffer)
-    (and
-     (member (bytes->string/latin-1 (subbytes buffer 0 4))
-             (list "true" "OTTO" "\u0\u1\u0\u0"))
-     'TTF-format))
-  
   (field [ft-library (FT_Init_FreeType)])
   (field [ft-face (FT_New_Face ft-library charter-path 0)])
 
@@ -254,8 +250,11 @@
   ((bytes?) ((or/c string? #f)) . ->* . any/c)
   (or
    (for*/first ([format (in-list formats)]
-                #:when (send (make-object format) probe buffer))
-     (define font (make-object format (open-input-bytes buffer)))
+                ;; rather than use a `probe` function,
+                ;; just try making a font with each format and see what happens
+                [font (in-value (with-handlers ([(curry eq? 'probe-fail) (λ (exn) #f)])
+                                  (make-object format (open-input-bytes buffer))))]
+                #:when font)
                (if postscriptName
                    (send font getFont postscriptName) ; used to select from collection files like TTC
                    font))

pitfall/pitfall/racket.rkt

@@ -22,7 +22,8 @@
      sugar/class
      sugar/js
      sugar/dict
-     sugar/stub)
+     sugar/stub
+     sugar/port)
 
 (module reader syntax/module-reader
   #:language 'pitfall/racket

pitfall/restructure/streamcoder.rkt

@@ -14,3 +14,29 @@
       (unless (is-a? stream REncodeStream)
         (raise-argument-error 'encode "REncodeStream" stream)))
     (inner (void) encode stream  . args)))
+
+#|
+(define-subclass RBase (RStreamcoder)
+
+  (define/overment (decode stream-or-port . args)
+    (unless (or (is-a? stream RDecodeStream) (input-port? stream-or-port))
+      (raise-argument-error 'decode "RDecodeStream or input port" stream))
+    (define stream (and stream-or-port
+                        (if (input-port? stream-or-port)
+                            (make-object RDecodeStream stream-or-port)
+                            stream-or-port)))
+    (inner (void) decode stream . args))
+
+  (define/overment (encode stream-or-port . args)
+    (report stream-or-port)
+    (when stream-or-port
+      (unless (or (is-a? stream-or-port REncodeStream) (output-port? stream-or-port))
+        (raise-argument-error 'encode "REncodeStream or output port" stream-or-port)))
+
+    (define stream (and stream-or-port
+                        (if (output-port? stream-or-port)
+                            (make-object REncodeStream stream-or-port)
+                            stream-or-port)))
+    
+    (inner (void) encode stream  . args)))
+|#

pitfall/sugar/port.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+(require racket/port)
+(provide (all-defined-out) (all-from-out racket/port))
+
+(define (port-position ip)
+  (define-values (line col pos) (port-next-location ip))
+  pos)