From 665ce5d36f1d9970ae25c1f93a3d194b6b5600a7 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 11 Jun 2017 18:54:20 -0700 Subject: [PATCH] cleaning up restructure --- pitfall/restructure/Untitled.rkt | 47 ---------- pitfall/restructure/decodestream.rkt | 39 -------- pitfall/restructure/encodestream.rkt | 19 ---- pitfall/restructure/helper.rkt | 9 +- pitfall/restructure/number.rkt | 91 ++++++++++--------- pitfall/restructure/racket.rkt | 6 +- pitfall/restructure/sizes.rkt | 35 ++++++++ pitfall/restructure/stream.rkt | 128 +++++++++++++++++++++++++++ pitfall/restructure/streamcoder.rkt | 18 ---- pitfall/sugar/class.rkt | 25 ++++-- 10 files changed, 236 insertions(+), 181 deletions(-) delete mode 100644 pitfall/restructure/Untitled.rkt delete mode 100644 pitfall/restructure/decodestream.rkt delete mode 100644 pitfall/restructure/encodestream.rkt create mode 100644 pitfall/restructure/sizes.rkt create mode 100644 pitfall/restructure/stream.rkt delete mode 100644 pitfall/restructure/streamcoder.rkt diff --git a/pitfall/restructure/Untitled.rkt b/pitfall/restructure/Untitled.rkt deleted file mode 100644 index 7c1cb2d7..00000000 --- a/pitfall/restructure/Untitled.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang restructure/racket -(require "number.rkt" "utils.rkt" "streamcoder.rkt") -(provide RArray) - -#| -approximates -https://github.com/mbutterick/restructure/blob/master/src/Array.coffee -|# - -(define-subclass RStreamcoder (RArray type [length #f] [lengthType 'count]) - - (define/augment (decode stream [parent #f]) - (let ([length (cond - [length - (resolveLength length stream parent)] - [else - (define num (send stream length)) - (define denom (send type size)) - (unless (andmap (λ (x) (and x (number? x))) (list num denom)) - (raise-argument-error 'RArray:decode "valid length and size" (list num denom))) - ;; implied length: length of stream divided by size of item - (floor (/ (send stream length) (send type size)))])]) - - (caseq lengthType - [(count) (for/list ([i (in-range length)]) - (send type decode stream this))]))) - - (define/override (size array) - (report array) - (for/sum ([item (in-list array)]) - (report item) - (send item size))) - - (define/augment (encode stream array [parent #f]) - (for ([item (in-list array)]) - (send type encode stream item)))) - - -(test-module - (require "decodestream.rkt" "encodestream.rkt") - (define stream (make-object RDecodeStream #"ABCDEFG")) - - (define A (make-object RArray uint16be 3)) - (check-equal? (send A decode stream) '(16706 17220 17734)) - (define os (make-object REncodeStream)) - (send A encode os '(16706 17220 17734)) - (check-equal? (send os dump) #"ABCDEF")) \ No newline at end of file diff --git a/pitfall/restructure/decodestream.rkt b/pitfall/restructure/decodestream.rkt deleted file mode 100644 index d50a3385..00000000 --- a/pitfall/restructure/decodestream.rkt +++ /dev/null @@ -1,39 +0,0 @@ -#lang restructure/racket -(provide (all-defined-out)) - -#| approximates -https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee -|# - -(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) - -(provide (rename-out [type-sizes TYPES])) - -(define type-sizes (let-values ([(intkeys intvalues) - (for*/lists (intkeys intvalues) - ([signed (in-list '(U ""))] - [size (in-list '(8 16 24 32))]) - (values - (format "~aInt~a" signed size) - (/ size 8)))]) - (for/hash ([key (in-list (append '(Float Double) intkeys))] - [value (in-list (append '(4 8) intvalues))] - #:when key - [endian '("" BE LE)]) - (values (string->symbol (format "~a~a" key endian)) value)))) - -;; basically just a wrapper for a Racket port -;; but needs to start with a buffer so length can be found -(define-subclass object% (RDecodeStream [buffer #""]) - (field [_port (if (bytes? buffer) - (open-input-bytes buffer) - (raise-argument-error 'RDecodeStream "bytes" buffer))]) - (getter-field [pos (port-position _port)]) - (getter-field [length (bytes-length buffer)]) - - (define/public (read count) - (read-bytes-exact count _port))) \ No newline at end of file diff --git a/pitfall/restructure/encodestream.rkt b/pitfall/restructure/encodestream.rkt deleted file mode 100644 index b90999ac..00000000 --- a/pitfall/restructure/encodestream.rkt +++ /dev/null @@ -1,19 +0,0 @@ -#lang restructure/racket -(provide (all-defined-out)) - -#| approximates -https://github.com/mbutterick/restructure/blob/master/src/EncodeStream.coffee -|# - -;; basically just a wrapper for a Racket outputport -(define-subclass object% (REncodeStream [bufferSize 65536]) - (field [_port (open-output-bytes)]) - (getter-field [pos (port-position _port)]) - - (define/public (dump) - (get-output-bytes _port)) - - (define/public (write val) - (cond - [(bytes? val) (write-bytes val _port) (void)] - [else (error 'REncodeStream:write:unknown-type)]))) \ No newline at end of file diff --git a/pitfall/restructure/helper.rkt b/pitfall/restructure/helper.rkt index e499d496..cbee36ef 100644 --- a/pitfall/restructure/helper.rkt +++ b/pitfall/restructure/helper.rkt @@ -2,7 +2,7 @@ (require (for-syntax racket/base br/syntax) racket/class br/define) (provide (all-defined-out)) -(define RBase +(define RestructureBase (class object% (super-new) (abstract decode) @@ -17,9 +17,4 @@ (require #,(datum->syntax caller-stx 'rackunit)) . EXPRS)) - -(define (port-position port) - (define-values (l c p) (port-next-location port)) - p) - - +(define index? (λ (x) (and (number? x) (integer? x) (not (negative? x))))) \ No newline at end of file diff --git a/pitfall/restructure/number.rkt b/pitfall/restructure/number.rkt index e8aabdd3..fff4b0ed 100644 --- a/pitfall/restructure/number.rkt +++ b/pitfall/restructure/number.rkt @@ -1,6 +1,6 @@ #lang restructure/racket -(require "decodestream.rkt" "encodestream.rkt" "streamcoder.rkt") -(provide Number) +(require "stream.rkt" "sizes.rkt" (for-syntax "sizes.rkt" racket/match)) +(provide (all-defined-out)) #| approximates @@ -18,55 +18,70 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (check-false (signed-type? 'UInt16)) (check-true (signed-type? 'Int16))) -(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) - (raise-argument-error 'Number "valid type and endian" (format "~v ~v" type endian))) +(define-subclass Streamcoder (Number [type 'UInt16] [endian (if (system-big-endian?) 'BE 'LE)]) + + (getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))]) + + ;; `get-type-size` will raise error if number-type is invalid: use this as check of input + ;; size of a number doesn't change, so we can stash it as `_size` + (define _size (with-handlers ([exn:fail:contract? + (λ (exn) + (raise-argument-error 'Number "valid type and endian" (format "~v ~v" type endian)))]) + (get-type-size number-type))) - (define/override (size . args) (hash-ref type-sizes fn)) + (define/override (size . args) _size) - (define/augment (decode stream [res #f]) - (define bstr (send stream read (size))) - (if (= 1 (size)) + (define/augment (decode stream . args) + (define bstr (send stream read _size)) + (if (= 1 _size) (bytes-ref bstr 0) (integer-bytes->integer bstr (signed-type? type) (eq? endian 'BE)))) (define/augment (encode stream val-in) - (define val (if (and (integer? val-in) (inexact? val-in)) - (inexact->exact val-in) - val-in)) - (define bstr - (if (= 1 (size)) - (bytes val) - (integer->integer-bytes val (size) (signed-type? type) (eq? endian 'BE)))) - (if stream (send stream write bstr) bstr))) + (define val (if (integer? val-in) (inexact->exact val-in) val-in)) + ;; todo: better bounds checking + #;(unless (<= (if (negative? val) (abs (* 2 val)) val) (expt 2 (* 8 _size))) + (raise-argument-error 'Number:encode (format "integer that fits in ~a byte(s)" _size) val)) + (define bstr (if (= 1 _size) + (bytes val) + (integer->integer-bytes val _size (signed-type? type) (eq? endian 'BE)))) + (send stream write bstr))) (test-module - (let ([o (make-object Number 'UInt16 'LE)] - [ip (make-object RDecodeStream (bytes 1 2 3 4))]) + (check-exn exn:fail:contract? (λ () (+Number 'not-a-valid-type))) + (check-exn exn:fail:contract? (λ () (send uint8 encode (+EncodeStream) 256))) + (check-not-exn (λ () (send uint8 encode (+EncodeStream) 255))) + (check-exn exn:fail:contract? (λ () (send uint16 encode (+EncodeStream) (add1 #xffff)))) + (check-not-exn (λ () (send uint16 encode (+EncodeStream) #xffff))) + + (let ([o (+Number 'UInt16 'LE)] + [ip (+DecodeStream (bytes 1 2 3 4))] + [op (open-output-bytes)]) (check-equal? (send o decode ip) 513) ;; 1000 0000 0100 0000 (check-equal? (send o decode ip) 1027) ;; 1100 0000 0010 0000 - (check-equal? (send o encode #f 513) (bytes 1 2)) - (check-equal? (send o encode #f 1027) (bytes 3 4))) - - (let ([o (make-object Number 'UInt16 'BE)] - [ip (make-object RDecodeStream (bytes 1 2 3 4))]) + (send o encode op 513) + (check-equal? (get-output-bytes op) (bytes 1 2)) + (send o encode op 1027) + (check-equal? (get-output-bytes op) (bytes 1 2 3 4))) + + (let ([o (+Number 'UInt16 'BE)] + [ip (+DecodeStream (bytes 1 2 3 4))] + [op (open-output-bytes)]) (check-equal? (send o decode ip) 258) ;; 0100 0000 1000 0000 - (check-equal? (send o decode ip) 772) ;; 0010 0000 1100 0000 - (check-equal? (send o encode #f 258) (bytes 1 2)) - (check-equal? (send o encode #f 772) (bytes 3 4)))) + (check-equal? (send o decode ip) 772) ;; 0010 0000 1100 0000 + (send o encode op 258) + (check-equal? (get-output-bytes op) (bytes 1 2)) + (send o encode op 772) + (check-equal? (get-output-bytes op) (bytes 1 2 3 4)))) (test-module - (check-equal? (send (make-object Number 'UInt8) size) 1) - (check-equal? (send (make-object Number) size) 2) - (check-equal? (send (make-object Number 'UInt32) size) 4) - (check-equal? (send (make-object Number 'Double) size) 8)) - + (check-equal? (send (+Number 'UInt8) size) 1) + (check-equal? (send (+Number) size) 2) + (check-equal? (send (+Number 'UInt32) size) 4) + (check-equal? (send (+Number 'Double) size) 8)) -(require (for-syntax "decodestream.rkt" racket/match)) ;; use keys of type-sizes hash to generate corresponding number definitions (define-macro (make-int-types) @@ -83,17 +98,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee [(ID ...) (suffix-id #'(ID ...) #:context caller-stx)]) #'(begin (define+provide ID (make-object Number 'BASE 'ENDIAN)) ...))) - (make-int-types) - (test-module (check-equal? (send uint8 size) 1) (check-equal? (send uint16 size) 2) (check-equal? (send uint32 size) 4) (check-equal? (send double size) 8)) - -(require "encodestream.rkt") -(define n (make-object Number 'UInt32)) -(send n encode (make-object REncodeStream) 2351070438) \ No newline at end of file diff --git a/pitfall/restructure/racket.rkt b/pitfall/restructure/racket.rkt index 68788278..ef395d0b 100644 --- a/pitfall/restructure/racket.rkt +++ b/pitfall/restructure/racket.rkt @@ -1,9 +1,10 @@ #lang racket/base -(require (for-syntax racket/base br/syntax)) +(require (for-syntax racket/base br/syntax) br/define) (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 ...)))) +(define-macro (r+p ID ...) + #'(begin (require ID ...) (provide (all-from-out ID ...)))) (r+p "helper.rkt" sugar/debug @@ -16,6 +17,7 @@ sugar/js sugar/dict sugar/stub + sugar/port sugar/case) (module reader syntax/module-reader diff --git a/pitfall/restructure/sizes.rkt b/pitfall/restructure/sizes.rkt new file mode 100644 index 00000000..ab2a5a31 --- /dev/null +++ b/pitfall/restructure/sizes.rkt @@ -0,0 +1,35 @@ +#lang restructure/racket +(provide type-sizes get-type-size) + +(define-values (int-keys byte-values) (for*/lists (int-keys byte-values) + ([signed (in-list '("U" ""))] + [bit-size (in-list '(8 16 24 32))]) + (values (format "~aInt~a" signed bit-size) (/ bit-size 8)))) + +(define type-sizes (for/hash ([type-key (in-list (append '("Float" "Double") int-keys))] + [byte-value (in-list (append '(4 8) byte-values))] + #:when #t + [endian (in-list '("" "BE" "LE"))]) + (values (string->symbol (string-append type-key endian)) byte-value))) + +(define (get-type-size key) + (hash-ref type-sizes key (λ () (raise-argument-error 'DecodeStream:get-type-size "valid type" key)))) + +(test-module + (check-equal? (get-type-size 'Int8) 1) + (check-equal? (get-type-size 'UInt8) 1) + (check-equal? (get-type-size 'UInt8BE) 1) + (check-equal? (get-type-size 'Int16) 2) + (check-equal? (get-type-size 'UInt16) 2) + (check-equal? (get-type-size 'UInt16BE) 2) + (check-equal? (get-type-size 'UInt16LE) 2) + (check-equal? (get-type-size 'UInt32) 4) + (check-equal? (get-type-size 'UInt32LE) 4) + (check-equal? (get-type-size 'Int32BE) 4) + (check-equal? (get-type-size 'Float) 4) + (check-equal? (get-type-size 'FloatLE) 4) + (check-equal? (get-type-size 'FloatBE) 4) + (check-equal? (get-type-size 'Double) 8) + (check-equal? (get-type-size 'DoubleLE) 8) + (check-equal? (get-type-size 'DoubleBE) 8) + (check-exn exn:fail:contract? (λ () (get-type-size 'not-a-type)))) \ No newline at end of file diff --git a/pitfall/restructure/stream.rkt b/pitfall/restructure/stream.rkt new file mode 100644 index 00000000..2fea4003 --- /dev/null +++ b/pitfall/restructure/stream.rkt @@ -0,0 +1,128 @@ +#lang restructure/racket +(provide (all-defined-out)) + +;; helper class +(define-subclass object% (PortWrapper _port) + (unless (port? _port) + (raise-argument-error 'PortWrapper:constructor "port" _port)) + (define/public-final (pos) (port-position _port)) + (define/public (dump) (void))) + +(test-module + (check-not-exn (λ () (make-object PortWrapper (open-input-bytes #"Foo")))) + (check-not-exn (λ () (make-object PortWrapper (open-output-bytes)))) + (check-exn exn:fail? (λ () (make-object PortWrapper -42)))) + +#| approximates +https://github.com/mbutterick/restructure/blob/master/src/EncodeStream.coffee +|# + +;; basically just a wrapper for a Racket output port +(define-subclass* PortWrapper (EncodeStream [maybe-output-port (open-output-bytes)]) + + (unless (output-port? maybe-output-port) + (raise-argument-error 'EncodeStream:constructor "output port" maybe-output-port)) + + (super-make-object maybe-output-port) + (inherit-field _port) + + (define/override-final (dump) (get-output-bytes _port)) + + (define/public-final (write val) + (unless (bytes? val) + (raise-argument-error 'EncodeStream:write "bytes" val)) + (void (write-bytes val (· this _port))))) + +(test-module + (define es (+EncodeStream)) + (check-true (EncodeStream? es)) + (send es write #"AB") + (check-equal? (· es pos) 2) + (send es write #"C") + (check-equal? (· es pos) 3) + (send es write #"D") + (check-equal? (· es pos) 4) + (check-exn exn:fail? (λ () (send es write -42))) + (check-exn exn:fail? (λ () (send es write 1))) + (define op (open-output-bytes)) + (define es2 (+EncodeStream op)) + (send es2 write #"FOOBAR") + (check-equal? (send es2 dump) #"FOOBAR") + (check-equal? (send es2 dump) #"FOOBAR") ; dump can repeat + (check-equal? (get-output-bytes op) #"FOOBAR")) + + +#| approximates +https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee +|# + +;; basically just a wrapper for a Racket port +;; but needs to start with a buffer so length can be found +(define-subclass* PortWrapper (DecodeStream [buffer #""]) + (unless (bytes? buffer) + (raise-argument-error 'DecodeStream:constructor "bytes" buffer)) + + (super-make-object (open-input-bytes buffer)) + (inherit-field _port) + + (getter-field [length (bytes-length buffer)]) + + (define/override-final (dump) + (define current-position (port-position _port)) + (set-port-position! _port 0) + (define bs (port->bytes _port)) + (set-port-position! _port current-position) + bs) + + (define/public-final (read count) + (unless (index? count) + (raise-argument-error 'DecodeStream:read "positive integer" count)) + (define bytes-remaining (- length (port-position _port))) + (when (> count bytes-remaining) + (raise-argument-error 'DecodeStream:read (format "byte count not more than bytes remaining = ~a" bytes-remaining) count)) + (read-bytes count _port))) + +(test-module + (define ds (+DecodeStream #"ABCD")) + (check-true (DecodeStream? ds)) + (check-equal? (send ds dump) #"ABCD") + (check-equal? (send ds dump) #"ABCD") ; dump can repeat + (check-equal? (send ds read 2) #"AB") + (check-equal? (send ds dump) #"ABCD") + (check-equal? (· ds pos) 2) + (check-equal? (send ds read 1) #"C") + (check-equal? (· ds pos) 3) + (check-equal? (send ds read 1) #"D") + (check-equal? (· ds pos) 4) + (check-exn exn:fail? (λ () (send ds read -42))) + (check-exn exn:fail? (λ () (send ds read 1)))) + + +;; Streamcoder is a helper class that checks / converts stream arguments before decode / encode +;; not a subclass of DecodeStream or EncodeStream, however. +(define-subclass RestructureBase (Streamcoder) + + (define/overment (decode x . args) + (define stream (if (bytes? x) (+DecodeStream x) x)) + (unless (DecodeStream? stream) + (raise-argument-error 'Streamcoder:decode "bytes or DecodeStream" x)) + (inner (void) decode stream . args)) + + (define/overment (encode x . args) + (define stream (if (output-port? x) (+EncodeStream x) x)) + (unless (EncodeStream? stream) + (raise-argument-error 'Streamcoder:encode "output port or EncodeStream" x)) + (inner (void) encode stream . args))) + +(test-module + (define-subclass Streamcoder (Dummy) + (define/augment (decode stream) "foo") + (define/augment (encode stream val) "bar") + (define/override (size) 42)) + + (define d (+Dummy)) + (check-true (Dummy? d)) + (check-exn exn:fail:contract? (λ () (send d decode 42))) + (check-not-exn (λ () (send d decode #"foo"))) + (check-exn exn:fail:contract? (λ () (send d encode 42 21))) + (check-not-exn (λ () (send d encode (open-output-bytes) 42)))) \ No newline at end of file diff --git a/pitfall/restructure/streamcoder.rkt b/pitfall/restructure/streamcoder.rkt deleted file mode 100644 index da2efddd..00000000 --- a/pitfall/restructure/streamcoder.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang restructure/racket -(require "decodestream.rkt" "encodestream.rkt") -(provide RStreamcoder) - -(define-subclass RBase (RStreamcoder) - (define/overment (decode x . args) - (let loop ([x x]) - (cond - [(bytes? x) (loop (open-input-bytes x))] - [(or (is-a? x RDecodeStream) (not x)) (inner (void) decode x . args)] - [else (raise-argument-error 'decode "item that can become RDecodeStream" x)]))) - - (define/overment (encode x . args) - (let loop ([x x]) - (cond - [(output-port? x) (loop (make-object REncodeStream x))] - [(or (is-a? x REncodeStream) (not x)) (inner (void) encode x . args)] - [else (raise-argument-error 'encode "item that can become REncodeStream" x)])))) \ No newline at end of file diff --git a/pitfall/sugar/class.rkt b/pitfall/sugar/class.rkt index 24a12dd6..cab6a85e 100644 --- a/pitfall/sugar/class.rkt +++ b/pitfall/sugar/class.rkt @@ -19,9 +19,9 @@ (define-macro (as-method ID) (with-pattern ([PRIVATE-ID (generate-temporary #'ID)]) - #'(begin - (public [PRIVATE-ID ID]) - (define (PRIVATE-ID . args) (apply ID this args))))) + #'(begin + (public [PRIVATE-ID ID]) + (define (PRIVATE-ID . args) (apply ID this args))))) (define-macro (as-methods ID ...) @@ -29,7 +29,16 @@ (define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) - #'(define ID (class SUPERCLASS (super-new) (init-field . INIT-ARGS) . BODY))) + #'(define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) + + +(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) + (with-pattern ([+ID (prefix-id "+" #'ID)] + [ID? (suffix-id #'ID "?")]) + #'(begin + (define ID (class SUPERCLASS (init-field . INIT-ARGS) . BODY)) + (define (ID? x) (is-a? x ID)) + (define (+ID . args) (apply make-object ID args))))) (define-macro (push-field! FIELD O EXPR) @@ -56,7 +65,7 @@ (define-macro (getter-field [ID . EXPRS]) (with-pattern ([_ID (prefix-id "_" #'ID)]) - #`(begin - (field [(ID _ID) . EXPRS]) - (public (_ID ID)) - (#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID)))) \ No newline at end of file + #`(begin + (field [(ID _ID) . EXPRS]) + (public (_ID ID)) + (#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID)))) \ No newline at end of file