From b3894c42e63f5951de7da8d0860c0c444c7dfcdd Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 7 Jun 2017 12:39:14 -0700 Subject: [PATCH] start restructure --- pitfall/binparser/object.rkt | 85 ++++++++++++++++++++++++++++ pitfall/pitfall/directory.rkt | 16 +----- pitfall/restructure/decodestream.rkt | 22 +++++++ pitfall/restructure/helper.rkt | 32 +++++++++++ pitfall/restructure/number.rkt | 47 +++++++++++++++ pitfall/restructure/racket.rkt | 17 ++++++ 6 files changed, 204 insertions(+), 15 deletions(-) create mode 100644 pitfall/binparser/object.rkt create mode 100644 pitfall/restructure/decodestream.rkt create mode 100644 pitfall/restructure/helper.rkt create mode 100644 pitfall/restructure/number.rkt create mode 100644 pitfall/restructure/racket.rkt diff --git a/pitfall/binparser/object.rkt b/pitfall/binparser/object.rkt new file mode 100644 index 00000000..b78d0ff0 --- /dev/null +++ b/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) ...))))) + +|# \ No newline at end of file diff --git a/pitfall/pitfall/directory.rkt b/pitfall/pitfall/directory.rkt index 06c95e9b..1acf0a78 100644 --- a/pitfall/pitfall/directory.rkt +++ b/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] diff --git a/pitfall/restructure/decodestream.rkt b/pitfall/restructure/decodestream.rkt new file mode 100644 index 00000000..35bc60ab --- /dev/null +++ b/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)] + ) + ) \ No newline at end of file diff --git a/pitfall/restructure/helper.rkt b/pitfall/restructure/helper.rkt new file mode 100644 index 00000000..d4e57eef --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/pitfall/restructure/number.rkt b/pitfall/restructure/number.rkt new file mode 100644 index 00000000..86d16d49 --- /dev/null +++ b/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)) + diff --git a/pitfall/restructure/racket.rkt b/pitfall/restructure/racket.rkt new file mode 100644 index 00000000..f48ae201 --- /dev/null +++ b/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))) \ No newline at end of file