stringage

pitfall/restructure/decodestream.rkt

@@ -25,5 +25,5 @@
          [_port (open-input-bytes buffer)])
   (getter-field [pos (port-position _port)])
 
-  (define/public (read-bytes count)
+  (define/public (read count)
     (read-bytes-exact count _port)))

pitfall/restructure/encodestream.rkt

@@ -15,5 +15,5 @@ https://github.com/mbutterick/restructure/blob/master/src/EncodeStream.coffee
 
   (define/public (write val)
     (cond
-      [(bytes? val) (write-bytes val _port)]
+      [(bytes? val) (write-bytes val _port) (void)]
       [else (error 'REncodeStream:write:unknown-type)])))

pitfall/restructure/helper.rkt

@@ -37,26 +37,26 @@
 
 (define-macro (define-stub-stop ID)
   (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":not-implemented")])
-                #'(define (ID . args)
-                    (error 'ERROR-ID))))
+    #'(define (ID . args)
+        (error 'ERROR-ID))))
 
 (provide (rename-out [define-stub-stop define-stub]))
 
 (define-macro (define-stub-go ID)
   (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":not-implemented")])
-                #'(define (ID . args)
-                    (displayln 'ERROR-ID))))
+    #'(define (ID . args)
+        (displayln 'ERROR-ID))))
 
 (define-macro (define-unfinished (ID . ARGS) . BODY)
   (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (syntax-source #'this) ":" #'ID) ":unfinished")])
-                #'(define (ID . ARGS)
-                    (begin . BODY)
-                    (error 'ID-UNFINISHED))))
+    #'(define (ID . ARGS)
+        (begin . BODY)
+        (error 'ID-UNFINISHED))))
 
 
 (define-macro (unfinished)
   (with-pattern ([ID-UNFINISHED (prefix-id (syntax-source caller-stx) ":" (syntax-line caller-stx) ":" #'unfinished)])
-                #'(error 'ID-UNFINISHED)))
+    #'(error 'ID-UNFINISHED)))
 
 (define-macro (define+provide ID . EXPRS)
   #'(begin
@@ -66,7 +66,7 @@
 (require sugar/list)
 (define (listify kvs)
   (for/list ([slice (in-list (slice-at kvs 2))])
-            (cons (car slice) (cadr slice))))
+    (cons (car slice) (cadr slice))))
 (define-syntax-rule (define-hashifier id hasher) (define (id . kvs) (hasher (listify kvs))))
 (define-hashifier mhash make-hash)
 (define-hashifier mhasheq make-hasheq)
@@ -84,4 +84,18 @@
                         (get-field ref x))]
          [(hash? x) (hash-ref x 'ref #f)]
          [else (raise-argument-error '· (format "~a must be object or hash" 'x) x)])]
-    [(_ x ref0 . refs) #'(· (· x ref0) . refs)]))
+    [(_ x ref0 . refs) #'(· (· x ref0) . refs)]))
+
+(define-macro (define-case-macro ID PRED)
+  #'(define-macro-cases ID
+      [(_ TEST-VAL [(MATCH0 . MATCH-VALS) . RESULT] (... ...) [else . ELSE-RESULT])
+       #'(cond
+           [(PRED TEST-VAL '(MATCH0 . MATCH-VALS)) . RESULT] (... ...)
+           [else . ELSE-RESULT])]
+      [(_ TEST-VAL MATCH-CLAUSE (... ...))
+       #'(ID TEST-VAL
+             MATCH-CLAUSE (... ...)
+             [else (error 'ID (format "no match for ~a" TEST-VAL))])]))
+
+;; like case but strictly uses `eq?` comparison (as opposed to `equal?`)
+(define-case-macro caseq memq)

pitfall/restructure/main.rkt

@@ -2,5 +2,6 @@
 
 (r+p "number.rkt"
      "struct.rkt"
+     "string.rkt"
      "decodestream.rkt"
      "encodestream.rkt")

pitfall/restructure/number.rkt

@@ -1,7 +1,11 @@
 #lang restructure/racket
-(require "decodestream.rkt" "encodestream.rkt")
+(require "decodestream.rkt" "encodestream.rkt" "streamcoder.rkt")
+(provide Number)
 
-;; approximates https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
+|#
 
 (define (ends-with-8? type)
   (define str (symbol->string type))
@@ -14,7 +18,7 @@
  (check-true (unsigned-type? 'UInt16))
  (check-false (unsigned-type? 'Int16)))
 
-(define-subclass RBase (Number [type 'UInt16] [endian (if (system-big-endian?) 'BE 'LE)])
+(define-subclass RStreamcoder (Number [type 'UInt16] [endian (if (system-big-endian?) 'BE 'LE)])
   (getter-field [fn (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))])
 
   (unless (hash-has-key? type-sizes fn)
@@ -22,18 +26,13 @@
   
   (getter-field [size (hash-ref type-sizes fn)])
 
-  (define/override (decode stream [res #f])
-    (unless (is-a? stream RDecodeStream)
-      (raise-argument-error 'decode "RDecodeStream" stream))
-    (define bstr (send stream read-bytes size))
+  (define/augment (decode stream [res #f])
+    (define bstr (send stream read size))
     (if (= 1 size)
         (bytes-ref bstr 0)
         (integer-bytes->integer bstr (unsigned-type? type) (eq? endian 'BE))))
 
-  (define/override (encode stream val)
-    (when stream
-      (unless (is-a? stream REncodeStream)
-        (raise-argument-error 'encode "REncodeStream" stream)))
+  (define/augment (encode stream val)
     (define bstr
       (if (= 1 size)
           (bytes val)

pitfall/restructure/streamcoder.rkt

@@ -0,0 +1,16 @@
+#lang restructure/racket
+(require "decodestream.rkt" "encodestream.rkt")
+(provide RStreamcoder)
+
+(define-subclass RBase (RStreamcoder)
+
+  (define/overment (decode stream . args)
+    (unless (is-a? stream RDecodeStream)
+      (raise-argument-error 'decode "RDecodeStream" stream))
+    (inner (void) decode stream . args))
+
+  (define/overment (encode stream . args)
+    (when stream
+      (unless (is-a? stream REncodeStream)
+        (raise-argument-error 'encode "REncodeStream" stream)))
+    (inner (void) encode stream  . args)))

pitfall/restructure/string.rkt

@@ -0,0 +1,38 @@
+#lang restructure/racket
+(require "number.rkt" "utils.rkt" "streamcoder.rkt")
+(provide RString)
+
+#|
+approximates
+https://github.com/mbutterick/restructure/blob/master/src/String.coffee
+|#
+
+(define-subclass RStreamcoder (RString [length #f] [encoding 'ascii])
+  (field [_codec (caseq encoding
+                        [(latin-1) (cons string->bytes/latin-1 bytes->string/latin-1)]
+                        [(ascii utf-8 utf8)(cons string->bytes/utf-8 bytes->string/utf-8)])])
+         
+  (define/augment (decode stream [parent #f])
+    (define count (if length
+                      (resolveLength length stream parent)
+                      (send stream length)))
+    (define bytes (send stream read count))
+    ((cdr _codec) bytes))
+
+  (define/augment (encode stream val [parent #f])
+    (define bytes ((car _codec) val))
+    
+    (when (is-a? length Number) ;; length-prefixed string
+      (send length encode stream (bytes-length bytes)))
+    
+    (send stream write bytes)))
+
+
+(test-module
+ (require "decodestream.rkt" "encodestream.rkt")
+ (define stream (make-object RDecodeStream #"\2BCDEF"))
+ (define S (make-object RString uint8 'utf8))
+ (check-equal? (send S decode stream) "BC")
+ (define os (make-object REncodeStream))
+ (send S encode os "Mike")
+ (check-equal? (send os dump) #"\4Mike"))

pitfall/restructure/test.rkt

@@ -3,20 +3,20 @@
 
 (define Person
   (make-object RStruct
-    (mhash 'name uint16
+    (mhash 'name (make-object RString uint8 'utf8)
            'age uint8)))
 
 ;; decode a person from a buffer
-(define stream (make-object RDecodeStream #"ABC"))
-(define x (send Person decode stream))
+(define stream-in (make-object RDecodeStream #"\4MikeA"))
+(define x (send Person decode stream-in))
 
 (test-module
- (check-equal? (hash-ref x 'name) 16961)
- (check-equal? (hash-ref x 'age) 67))
+ (check-equal? (hash-ref x 'name) "Mike")
+ (check-equal? (hash-ref x 'age) 65))
 
 ;; encode a person from a hash
-(define out (make-object REncodeStream))
-(send Person encode out (hasheq 'name 16961 'age 67))
+(define stream-out (make-object REncodeStream))
+(send Person encode stream-out (hasheq 'name "Mike" 'age 65))
 
 (test-module
- (check-equal? (send out dump) #"ABC"))
+ (check-equal? (send stream-out dump) #"\4MikeA"))

pitfall/restructure/utils.rkt

@@ -0,0 +1,11 @@
+#lang restructure/racket
+(provide (all-defined-out))
+(require "number.rkt")
+
+(define (resolveLength length stream parent)
+  (cond
+    [(number? length) length]
+    [(procedure? length) (length parent)]
+    [(and parent (string? length) (· parent length))]
+    [(and stream (is-a? length Number) (send length decode stream))]
+    [else (raise-argument-error 'resolveLength "fixed-size item" length)]))