start restructure

pitfall/binparser/object.rkt

@@ -0,0 +1,85 @@
+#lang br
+
+(define (read-bytes-exact count p)
+  (define bs (read-bytes count p))
+  (unless (and (bytes? bs) (= (bytes-length bs) count))
+    (raise-argument-error 'read-bytes-exact (format "byte string length ~a" count) bs))
+  bs)
+
+(define BinaryIO%
+  (class object%
+    (super-new)    
+    (abstract decode)
+    (abstract encode)
+    (abstract size)))
+
+
+(define ByteIO%
+  (class BinaryIO%
+    (super-new)
+    (init-field [_count 1])
+    (field [_bytes null])
+
+    (define/override (decode ip)
+      (set! _bytes (read-bytes-exact _count ip)))
+
+    (define/override (encode op val) (write-bytes _bytes op))
+
+    (define/override (size) (bytes-length _bytes))))
+
+(define b (make-object ByteIO%))
+
+(define ip (open-input-bytes #"ABC"))
+
+(send b decode ip)
+
+(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY)
+  #'(define ID (class SUPERCLASS (super-new) (init-field . INIT-ARGS) . BODY)))
+
+(define-macro (getter-field [ID . EXPRS])
+  (with-pattern ([_ID (prefix-id "_" #'ID)])
+    #'(begin
+        (field [(ID _ID)  . EXPRS])
+        (public (_ID ID))
+        (define (_ID) ID))))
+
+(define (ends-with-8? type)
+  (equal? (substring type (sub1 (string-length type))) "8"))
+
+(define-subclass BinaryIO% (NumberT type [endian (if (system-big-endian?) 'BE 'LE)])
+  (getter-field [fn (format "~a~a" type (if (ends-with-8? type)
+                                            ""
+                                            endian))])
+
+  (define/override (decode ip) 'foo)
+
+  (define/override (encode op val) 'foo)
+
+  (define/override (size) 'foo))
+    
+
+(define o (make-object NumberT "UInt16"))
+
+(send o fn)
+
+
+
+
+#|
+(define uint32be (:bytes 4 #:type integer/be?))
+(define uint16be (:bytes 2 #:type integer/be?))
+(define hexbytes (:bytes 4 #:type hex?))
+(define (:make-string count) (:bytes count #:type string/ascii?))
+
+(require (for-syntax sugar/debug))
+(define-macro (:seq ([ID BINDING . MAYBE-GUARD] ...) . BODY)
+  (with-pattern ([(GUARD ...) (pattern-case-filter #'(MAYBE-GUARD ...)
+                                                   [(#:assert PRED) #'(λ (x) (unless (PRED x) (error 'assert-failed)))]
+                                                   [ELSE #'void])])
+                #'(λ (p) (let* ([ID (let ([ID (BINDING p)])
+                                      (GUARD ID)
+                                      ID)] ...)
+                           (begin . BODY)
+                           (list (cons 'ID ID) ...)))))
+
+|#

pitfall/pitfall/directory.rkt

@@ -1,23 +1,9 @@
 #lang pitfall/racket
 (provide (all-defined-out))
 
-(require binparser)
+(require binparser/object)
 
-(define uint32be (:bytes 4 #:type integer/be?))
-(define uint16be (:bytes 2 #:type integer/be?))
-(define hexbytes (:bytes 4 #:type hex?))
-(define (:make-string count) (:bytes count #:type string/ascii?))
 
-(require (for-syntax sugar/debug))
-(define-macro (:seq ([ID BINDING . MAYBE-GUARD] ...) . BODY)
-  (with-pattern ([(GUARD ...) (pattern-case-filter #'(MAYBE-GUARD ...)
-                                                   [(#:assert PRED) #'(λ (x) (unless (PRED x) (error 'assert-failed)))]
-                                                   [ELSE #'void])])
-                #'(λ (p) (let* ([ID (let ([ID (BINDING p)])
-                                      (GUARD ID)
-                                      ID)] ...)
-                           (begin . BODY)
-                           (list (cons 'ID ID) ...)))))
 
 (define TableEntry (:seq ([tag (:make-string 4)]
                           [checkSum uint32be]

pitfall/restructure/decodestream.rkt

@@ -0,0 +1,22 @@
+#lang restructure/racket
+(provide (all-defined-out))
+
+;; approximates https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee
+
+(define TYPES (let-values ([(intkeys intvalues)
+                            (for*/lists (intkeys intvalues)
+                                        ([signed (in-list '(U ""))]
+                                         [size (in-list '(8 16 24 32))]
+                                         [endian (in-list '("" BE LE))])
+                                        (values
+                                         (string->symbol (format "~aInt~a~a" signed size endian))
+                                         (/ size 8)))])
+                (for/hash ([key (in-list (append '(Float Double) intkeys))]
+                           [value (in-list (append '(4 8) intvalues))])
+                          (values key value))))
+
+(define-subclass object% (DecodeStream [buffer #""])
+  (field [pos 0]
+         [length (bytes-length buffer)]
+         )
+  )

pitfall/restructure/helper.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax) racket/class br/define)
+(provide (all-defined-out))
+
+(define (read-bytes-exact count p)
+  (define bs (read-bytes count p))
+  (unless (and (bytes? bs) (= (bytes-length bs) count))
+    (raise-argument-error 'read-bytes-exact (format "byte string length ~a" count) bs))
+  bs)
+
+(define BinaryIO%
+  (class object%
+    (super-new)    
+    (abstract decode)
+    (abstract encode)
+    (abstract size)))
+
+
+(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY)
+  #'(define ID (class SUPERCLASS (super-new) (init-field . INIT-ARGS) . BODY)))
+
+(define-macro (getter-field [ID . EXPRS])
+  (with-pattern ([_ID (prefix-id "_" #'ID)])
+    #'(begin
+        (field [(ID _ID)  . EXPRS])
+        (public (_ID ID))
+        (define (_ID) ID))))
+
+(define-macro (test-module . EXPRS)
+  #`(module+ test
+      (require #,(datum->syntax caller-stx 'rackunit))
+      . EXPRS))

pitfall/restructure/number.rkt

@@ -0,0 +1,47 @@
+#lang restructure/racket
+(require "decodestream.rkt")
+
+;; approximates https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
+
+(define (ends-with-8? type)
+  (define str (symbol->string type))
+  (equal? (substring str (sub1 (string-length str))) "8"))
+
+(define (unsigned-type? type)
+  (equal? "U" (substring (symbol->string type) 0 1)))
+
+(test-module
+ (check-true (unsigned-type? 'UInt16))
+ (check-false (unsigned-type? 'Int16)))
+
+(define-subclass BinaryIO% (NumberT type [endian (if (system-big-endian?) 'BE 'LE)])
+  (getter-field [fn (format "~a~a" type (if (ends-with-8? type) "" endian))])
+
+  (define/override (decode stream)
+    (define bstr (read-bytes-exact (size) stream))
+    (if (= 1 (size))
+        (bytes-ref bstr 0)
+        (integer-bytes->integer bstr (unsigned-type? type) (eq? endian 'BE))))
+
+  (define/override (encode op val) 'foo)
+
+  (define/override (size) (hash-ref TYPES type)))
+    
+
+(test-module
+ (let ([o (make-object NumberT 'UInt16 'LE)]
+       [ip (open-input-bytes (bytes 1 2 3 4))])
+   (check-equal? (send o decode ip) 513) ;; 1000 0000  0100 0000
+   (check-equal? (send o decode ip) 1027)) ;; 1100 0000 0010 0000
+
+ (let ([o (make-object NumberT 'UInt16 'BE)]
+       [ip (open-input-bytes (bytes 1 2 3 4))])
+   (check-equal? (send o decode ip) 258) ;; 0100 0000 1000 0000 
+   (check-equal? (send o decode ip) 772))) ;; 0010 0000 1100 0000 
+
+
+(test-module
+ (check-equal? (send (make-object NumberT 'UInt8) size) 1)
+ (check-equal? (send (make-object NumberT 'UInt32) size) 4)
+ (check-equal? (send (make-object NumberT 'Double) size) 8))
+

pitfall/restructure/racket.rkt

@@ -0,0 +1,17 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax))
+(provide (for-syntax (all-from-out racket/base br/syntax)))
+(provide (all-from-out racket/base) r+p)
+
+(define-syntax-rule (r+p id ...) (begin (require id ...) (provide (all-from-out id ...))))
+
+(r+p "helper.rkt"
+     sugar/debug
+     racket/class
+     br/define)
+
+(module reader syntax/module-reader
+  #:language 'restructure/racket
+  #:read @-read
+  #:read-syntax @-read-syntax
+  (require (prefix-in @- scribble/reader)))