class0

xenomorph/xenomorph/helper.rkt

@@ -1,10 +1,13 @@
-#lang racket/base
+#lang debug racket/base
 (require racket/generic
+         racket/private/generic-methods
          racket/dict
-         racket/port)
+         racket/port
+         racket/class)
 (provide (all-defined-out))
 
-(define current-parent (make-parameter #f))
+(define (->output-port arg)
+  (if (output-port? arg) arg (open-output-bytes)))
 
 (define (->input-port arg)
   (cond
@@ -12,19 +15,23 @@
     [(input-port? arg) arg]
     [else (raise-argument-error '->input-port "byte string or input port" arg)]))
 
-(define (dict-ref* d . keys)
-  (for/fold ([d d])
-            ([k (in-list keys)])
-    (dict-ref d k)))
-
 (define private-keys '(parent _startOffset _currentOffset _length))
-(define (dict->mutable-hash x)
+(define (dump-mutable x)
   (define h (make-hasheq))
-  (for ([(k v) (in-dict x)]
-        #:unless (memq k private-keys))
+  (for ([(k v) (in-dict (dump x))])
     (hash-set! h k v))
   h)
 
+(define (dump x)
+  (cond
+    [(input-port? x) (port->bytes x)]
+    [(output-port? x) (get-output-bytes x)]
+    [(dict? x) (for/hasheq ([(k v) (in-dict x)]
+                            #:unless (memq k private-keys))
+                 (values k v))]
+    [(list? x) (map dump x)]
+    [else x]))
+
 (define (pos p [new-pos #f])
   (when new-pos
     (file-position p new-pos))
@@ -55,12 +62,44 @@
 
 (define-generics xenomorphic
   (encode xenomorphic val [port] #:parent [parent])
-  (xdecode xenomorphic [port] #:parent [parent])
-  (decode xenomorphic [port])
+  (decode xenomorphic [port] #:parent [parent])
   (size xenomorphic [item] #:parent [parent]))
 
 (define (finalize-size size)
   (cond
     [(void? size) 0]
     [(and (integer? size) (not (negative? size))) size]
-    [else (raise-argument-error 'size "nonnegative integer" size)]))
+    [else (raise-argument-error 'size "nonnegative integer" size)]))
+
+
+(define codec<%>
+  (interface* ()
+              ([(generic-property gen:xenomorphic)
+                (generic-method-table gen:xenomorphic                                      
+                                      (define (decode o [port-arg (current-input-port)] #:parent [parent #f])
+                                        (send o xxdecode (->input-port port-arg) parent))
+                                      
+                                      (define (encode o val [port-arg (current-output-port)] #:parent [parent #f])
+                                        (define port (->output-port port-arg))
+                                        (send o xxencode val port parent)
+                                        (unless port-arg (get-output-bytes port)))
+                                      
+                                      (define (size o [val #f] #:parent [parent #f])
+                                        (send o xxsize val parent)))])))
+
+(define xenobase%
+  (class* object% (codec<%>)
+    (super-new)
+    
+    (define/pubment (xxdecode input-port [parent #f])
+      (post-decode (inner (void) xxdecode input-port parent)))
+    
+    (define/pubment (xxencode val output-port [parent #f])
+      (define encode-result (inner (void) xxencode (pre-encode val) output-port parent))
+      (when (bytes? encode-result) (write-bytes encode-result output-port)))
+    
+    (define/pubment (xxsize [val #f] [parent #f])
+      (finalize-size (inner (void) xxsize val parent)))
+    
+    (define/public (post-decode val) val)
+    (define/public (pre-encode val) val)))

xenomorph/xenomorph/number.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require "helper.rkt")
+(require "helper.rkt" racket/class)
 (provide (all-defined-out))
 
 #|
@@ -23,71 +23,71 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
 
 (define system-endian (if (system-big-endian?) 'be 'le))
 
-(define/pre-encode (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f])
-  (unless (xint? i)
-    (raise-argument-error 'encode "xint instance" i))
-  (define-values (bound-min bound-max) (bounds i))
-  (unless (<= bound-min val bound-max)
-    (raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (xint-signed i) "signed" "unsigned") (xint-size i) bound-min bound-max) val))
-  (unless (or (not port-arg) (output-port? port-arg))
-    (raise-argument-error 'encode "output port or #f" port-arg))
-  (define port (if (output-port? port-arg) port-arg (open-output-bytes)))
-  (parameterize ([current-output-port port])
-    (define bs (for/fold ([bs null]
-                          [val (exact-if-possible val)]
-                          #:result bs)
-                         ([i (in-range (xint-size i))])
-                 (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8))))
-    (define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs)))
-    (if port-arg (write-bytes res) res)))
-
-(define/post-decode (xint-decode i [port-arg (current-input-port)] #:parent [parent #f])
-  (unless (xint? i)
-    (raise-argument-error 'decode "xint instance" i))
-  (define port (->input-port port-arg))
-  (parameterize ([current-input-port port])
-    (define bstr (read-bytes (xint-size i)))
-    (define bs ((if (eq? (xint-endian i) system-endian)
-                    values
-                    reverse-bytes) bstr))
-    (define uint (for/sum ([b (in-bytes bs)]
-                           [i (in-naturals)])
-                   (arithmetic-shift b (* 8 i))))
-    (if (xint-signed i) (unsigned->signed uint (bits i)) uint)))
+#;(define/pre-encode (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f])
+    )
+
+#;(define/post-decode (xint-decode i [port-arg (current-input-port)] #:parent [parent #f])
+    (unless (xint? i)
+      (raise-argument-error 'decode "xint instance" i))
+    )
 
 (struct xnumber xbase () #:transparent)
+(define xnumber% (class* xenobase% () (super-new)))
+
+(define xint% (class* xnumber% ()
+                (super-new)
+                (init-field size
+                            signed
+                            endian)
+                
+                (define/augment (xxdecode port [parent #f])
+                  (define bstr (read-bytes size port))
+                  (define bs ((if (eq? endian system-endian)
+                                  values
+                                  reverse-bytes) bstr))
+                  (define uint (for/sum ([b (in-bytes bs)]
+                                         [i (in-naturals)])
+                                 (arithmetic-shift b (* 8 i))))
+                  (if signed (unsigned->signed uint (bits this)) uint))
+                
+                (define/augment (xxencode val port [parent #f])
+                  (define-values (bound-min bound-max) (bounds this))
+                  (unless (<= bound-min val bound-max)
+                    (raise-argument-error 'encode
+                                          (format "value that fits within ~a ~a-byte int (~a to ~a)" (if signed "signed" "unsigned") size bound-min bound-max) val))
+                  (for/fold ([bs null]
+                             [val (exact-if-possible val)]
+                             #:result (apply bytes ((if (eq? endian 'be) values reverse) bs)))
+                            ([i (in-range size)])
+                    (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8))))
+                
+                (define/augment (xxsize [val #f] [parent #f]) size)))
 
-(struct xint xnumber (size signed endian) #:transparent
-  #:methods gen:xenomorphic
-  [(define decode xint-decode)
-   (define xdecode xint-decode)
-   (define encode xint-encode)
-   (define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))])
 
 (define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian])
   (unless (exact-positive-integer? size)
     (raise-argument-error '+xint "exact positive integer" size))
   (unless (memq endian '(le be))
     (raise-argument-error '+xint "'le or 'be" endian))
-  (xint size signed endian))
+  (make-object xint% size signed endian))
 
-(define (type-tag i)
-  (string->symbol
-   (string-append (if (xint-signed i) "" "u")
-                  "int"
-                  (number->string (bits i))
-                  (if (> (xint-size i) 1) (symbol->string (xint-endian i)) ""))))
+#;(define (type-tag i)
+    (string->symbol
+     (string-append (if signed "" "u")
+                    "int"
+                    (number->string (bits i))
+                    (if (> (xint-size i) 1) (symbol->string (xint-endian i)) ""))))
 
-(define (bits i) (* (xint-size i) 8))
+(define (bits i) (* (get-field size i) 8))
 
 (define (bounds i)
-  (unless (xint? i)
-    (raise-argument-error 'bounds "integer instance" i))
+  #;(unless (xint? i)
+      (raise-argument-error 'bounds "integer instance" i))
   ;; if a signed integer has n bits, it can contain a number
   ;; between - (expt 2 (sub1 n)) and (sub1 (expt 2 (sub1 n)).
   (let* ([signed-max (sub1 (arithmetic-shift 1 (sub1 (bits i))))]
          [signed-min (sub1 (- signed-max))]
-         [delta (if (xint-signed i) 0 signed-min)])
+         [delta (if (get-field signed i) 0 signed-min)])
     (values (- signed-min delta) (- signed-max delta))))
 
 (define int8 (+xint 1))
@@ -157,82 +157,3 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
   (check-equal? (decode int8 (bytes 255)) -1)
   (check-equal? (encode int8 -1 #f) (bytes 255))
   (check-equal? (encode int8 127 #f) (bytes 127)))
-
-(define/post-decode (xfloat-decode xf [port-arg (current-input-port)] #:parent [parent #f])
-  (unless (xfloat? xf)
-    (raise-argument-error 'decode "xfloat instance" xf))
-  (define bs (read-bytes (xfloat-size xf) (->input-port port-arg)))
-  (floating-point-bytes->real bs (eq? (xfloat-endian xf) 'be)))
-
-(define/pre-encode (xfloat-encode xf val [port (current-output-port)] #:parent [parent #f])
-  (unless (xfloat? xf)
-    (raise-argument-error 'encode "xfloat instance" xf))
-  (unless (or (not port) (output-port? port))
-    (raise-argument-error 'encode "output port or #f" port))
-  (define res (real->floating-point-bytes val (xfloat-size xf) (eq? (xfloat-endian xf) 'be)))
-  (if port (write-bytes res port) res))
-
-(struct xfloat xnumber (size endian) #:transparent
-  #:methods gen:xenomorphic
-  [(define decode xfloat-decode)
-   (define xdecode xfloat-decode)
-   (define encode xfloat-encode)
-   (define size (λ (i [item #f] #:parent [parent #f]) (xfloat-size i)))])
-
-(define (+xfloat [size 4] #:endian [endian system-endian])
-  (unless (exact-positive-integer? size)
-    (raise-argument-error '+xfloat "exact positive integer" size))
-  (unless (memq endian '(le be))
-    (raise-argument-error '+xfloat "'le or 'be" endian))
-  (xfloat size endian))
-
-(define float (+xfloat 4))
-(define floatbe (+xfloat 4 #:endian 'be))
-(define floatle (+xfloat 4 #:endian 'le))
-
-(define double (+xfloat 8))
-(define doublebe (+xfloat 8 #:endian 'be))
-(define doublele (+xfloat 8 #:endian 'le))
-
-(define/post-decode (xfixed-decode xf [port-arg (current-input-port)] #:parent [parent #f])
-  (unless (xfixed? xf)
-    (raise-argument-error 'decode "xfixed instance" xf))
-  (define int (xint-decode xf port-arg))
-  (exact-if-possible (/ int (fixed-shift xf) 1.0)))
-
-(define/pre-encode (xfixed-encode xf val [port (current-output-port)] #:parent [parent #f])
-  (unless (xfixed? xf)
-    (raise-argument-error 'encode "xfixed instance" xf))
-  (define int (exact-if-possible (floor (* val (fixed-shift xf)))))
-  (xint-encode xf int port))
-
-(struct xfixed xint (fracbits) #:transparent
-  #:methods gen:xenomorphic
-  [(define decode xfixed-decode)
-   (define xdecode xfixed-decode)
-   (define encode xfixed-encode)
-   (define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))])
-
-(define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] [fracbits (/ (* size 8) 2)])
-  (unless (exact-positive-integer? size)
-    (raise-argument-error '+xfixed "exact positive integer" size))
-  (unless (exact-positive-integer? fracbits)
-    (raise-argument-error '+xfixed "exact positive integer" fracbits))
-  (unless (memq endian '(le be))
-    (raise-argument-error '+xfixed "'le or 'be" endian))
-  (xfixed size signed endian fracbits))
-
-(define (fixed-shift xf)
-  (arithmetic-shift 1 (xfixed-fracbits xf)))
-
-(define fixed16 (+xfixed 2))
-(define fixed16be (+xfixed 2 #:endian 'be))
-(define fixed16le (+xfixed 2 #:endian 'le))
-(define fixed32 (+xfixed 4))
-(define fixed32be (+xfixed 4 #:endian 'be))
-(define fixed32le (+xfixed 4 #:endian 'le))
-
-(module+ test
-  (define bs (encode fixed16be 123.45 #f))
-  (check-equal? bs #"{s")
-  (check-equal? (ceiling (* (decode fixed16be bs) 100)) 12345.0))