diff --git a/pitfall/restructure/decodestream.rkt b/pitfall/restructure/decodestream.rkt index 89c807fc..efc3524a 100644 --- a/pitfall/restructure/decodestream.rkt +++ b/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))) \ No newline at end of file diff --git a/pitfall/restructure/encodestream.rkt b/pitfall/restructure/encodestream.rkt index 3ce103c2..b90999ac 100644 --- a/pitfall/restructure/encodestream.rkt +++ b/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)]))) \ No newline at end of file diff --git a/pitfall/restructure/helper.rkt b/pitfall/restructure/helper.rkt index 943c0db8..9eb77d7b 100644 --- a/pitfall/restructure/helper.rkt +++ b/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)])) \ No newline at end of file + [(_ 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) \ No newline at end of file diff --git a/pitfall/restructure/main.rkt b/pitfall/restructure/main.rkt index 2c05543a..576756e4 100644 --- a/pitfall/restructure/main.rkt +++ b/pitfall/restructure/main.rkt @@ -2,5 +2,6 @@ (r+p "number.rkt" "struct.rkt" + "string.rkt" "decodestream.rkt" "encodestream.rkt") \ No newline at end of file diff --git a/pitfall/restructure/number.rkt b/pitfall/restructure/number.rkt index decf886b..21f030c9 100644 --- a/pitfall/restructure/number.rkt +++ b/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) diff --git a/pitfall/restructure/streamcoder.rkt b/pitfall/restructure/streamcoder.rkt new file mode 100644 index 00000000..8c374374 --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/pitfall/restructure/string.rkt b/pitfall/restructure/string.rkt new file mode 100644 index 00000000..ee87f6e6 --- /dev/null +++ b/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")) \ No newline at end of file diff --git a/pitfall/restructure/test.rkt b/pitfall/restructure/test.rkt index 68c0dc38..ebea3903 100644 --- a/pitfall/restructure/test.rkt +++ b/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")) \ No newline at end of file + (check-equal? (send stream-out dump) #"\4MikeA")) \ No newline at end of file diff --git a/pitfall/restructure/utils.rkt b/pitfall/restructure/utils.rkt new file mode 100644 index 00000000..90c57374 --- /dev/null +++ b/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)])) \ No newline at end of file