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 #"")])
+(define-subclass object% (TTFFont stream)
-  (super-new)
   (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)])
+  (field [_directoryPos (port-position stream)]
-                          p)]
          [_tables (mhash)]
          [_glyphs (mhash)]
          [_layoutEngine #f])
@@ -25,9 +28,9 @@
   (send this _decodeDirectory)
 
   #;(define/public (_getTable tag)
-    (unless (member (· directory  tag) _tables)
+      (unless (member (· directory  tag) _tables)
-      (raise-argument-error '_getTable "table that exists" (· table tag)))
+        (raise-argument-error '_getTable "table that exists" (· table tag)))
-    (hash-set! _tables (· table tag) (_decodeTable table)))
+      (hash-set! _tables (· table tag) (_decodeTable table)))
 
   (define/public (_decodeTable table)
     (define-values (l c p) (port-next-location stream))
@@ -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)])
 
@@ -208,7 +204,7 @@
   ;; for now, just use UTF-8
   (define codepoints (map char->integer (string->list string)))
   (for/list ([cp (in-list codepoints)])
-    (send this glyphForCodePoint cp)))
+            (send this glyphForCodePoint cp)))
 
 
 ;; Maps a single unicode code point to a Glyph object.
@@ -231,7 +227,7 @@
   (string? number? . ->m . number?)
   (/ (* size
         (for/sum ([c (in-string str)])
-          (measure-char-width this c))) (· this unitsPerEm)))
+                 (measure-char-width this c))) (· this unitsPerEm)))
 
 
 ;; Register font formats
@@ -254,11 +250,14 @@
   ((bytes?) ((or/c string? #f)) . ->* . any/c)
   (or
    (for*/first ([format (in-list formats)]
-                #:when (send (make-object format) probe buffer))
+                ;; rather than use a `probe` function,
-     (define font (make-object format (open-input-bytes buffer)))
+                ;; just try making a font with each format and see what happens
-     (if postscriptName
+                [font (in-value (with-handlers ([(curry eq? 'probe-fail) (λ (exn) #f)])
-         (send font getFont postscriptName) ; used to select from collection files like TTC
+                                  (make-object format (open-input-bytes buffer))))]
-         font))
+                #:when font)
+               (if postscriptName
+                   (send font getFont postscriptName) ; used to select from collection files like TTC
+                   font))
    (error 'fontkit:create "unknown font format")))
 
 

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

@@ -13,4 +13,30 @@
     (when stream
       (unless (is-a? stream REncodeStream)
         (raise-argument-error 'encode "REncodeStream" stream)))
-    (inner (void) encode stream  . args)))
+    (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/restructure/struct.rkt

@@ -11,7 +11,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
   (field [key-index (map car assocs)]
          [fields (mhash)])
   (for ([(k v) (in-dict assocs)])
-    (hash-set! fields k v))
+       (hash-set! fields k v))
 
   (define/override (decode stream [parent #f] [length 0])
     (define res (_setup stream parent length))
@@ -21,26 +21,26 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
 
   (define/override (encode stream val [parent #f])
     (for ([key (in-list key-index)])
-      (send (hash-ref fields key) encode stream (hash-ref val key))))
+         (send (hash-ref fields key) encode stream (hash-ref val key))))
 
   (define/private (_setup stream parent length)
     (define res (mhasheq))
 
     ;; define hidden properties
     #;(hash-set! res '_props
-               (mhasheq 'parent (mhasheq 'value parent)
+                 (mhasheq 'parent (mhasheq 'value parent)
-                        '_startOffset (mhasheq 'value (· stream pos))
+                          '_startOffset (mhasheq 'value (· stream pos))
-                        '_currentOffset (mhasheq 'value 0 'writable #t)
+                          '_currentOffset (mhasheq 'value 0 'writable #t)
-                        '_length (mhasheq 'value length)))
+                          '_length (mhasheq 'value length)))
     res)
 
   (define/private (_parseFields stream res field)
-    (for ([key (in-list key-index)])
+    (for ([key (in-list key-index)])         
-      (define hashvalue (hash-ref fields key))
+         (define hashvalue (hash-ref fields key))      
-      (define val
+         (define val
-        (if (procedure? hashvalue)
+           (if (procedure? hashvalue)
-            (hashvalue res)
+               (hashvalue res)
-            (send hashvalue decode stream res)))
+               (send hashvalue decode stream res)))
-      (hash-set! res key val)))
+         (hash-set! res key val)))
 
   )

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)