mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

match it

Browse Source
main
Matthew Butterick 6 years ago
parent adadae2154
commit c1ca6d6560
8 changed files with 72 additions and 77 deletions
Show Stats Download Patch File Download Diff File

18
xenomorph/xenomorph/buffer.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require racket/class "helper.rkt" "util.rkt" "number.rkt") (require racket/class racket/match "helper.rkt" "util.rkt" "number.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
#| #|
@ -12,25 +12,23 @@ https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
(super-new) (super-new)
(init-field [(@len len)]) (init-field [(@len len)])
(unless (length-resolvable? @len) (unless (length-resolvable? @len)
(raise-argument-error '+xbuffer "resolvable length" @len)) (raise-argument-error 'x:buffer "resolvable length" @len))
(define/augment (x:decode port parent) (define/augment (x:decode port parent)
(define len (resolve-length @len port parent)) (read-bytes (resolve-length @len port parent)))
(read-bytes len))
(define/augment (x:encode buf port [parent #f]) (define/augment (x:encode buf port [parent #f])
(unless (bytes? buf) (unless (bytes? buf)
(raise-argument-error 'xbuffer-encode "bytes" buf)) (raise-argument-error 'x:buffer-encode "bytes" buf))
(when (x:int? @len) (when (x:int? @len)
(send @len x:encode (bytes-length buf) port)) (send @len x:encode (bytes-length buf) port))
(write-bytes buf port)) (write-bytes buf port))
(define/augment (x:size [val #f] [parent #f]) (define/augment (x:size [val #f] [parent #f])
(when val (unless (bytes? val) (match val
(raise-argument-error 'xbuffer-size "bytes" val))) [(? bytes?) (bytes-length val)]
(if (bytes? val) [(== #false) (resolve-length @len val parent)]
(bytes-length val) [_ (raise-argument-error 'x:buffer-size "bytes or #f" val)]))))
(resolve-length @len val parent)))))
(define (x:buffer [len-arg #f] (define (x:buffer [len-arg #f]
#:length [len-kwarg #f] #:length [len-kwarg #f]

13
xenomorph/xenomorph/enum.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require racket/class "helper.rkt" racket/list) (require racket/class racket/match "helper.rkt" racket/list)
(provide (all-defined-out)) (provide (all-defined-out))
#| #|
@ -13,19 +13,18 @@ https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
(init-field [(@type type)] [(@values values)]) (init-field [(@type type)] [(@values values)])
(unless (xenomorphic-type? @type) (unless (xenomorphic-type? @type)
(raise-argument-error '+xenum "xenomorphic type" @type)) (raise-argument-error 'x:enum "xenomorphic type" @type))
(unless (list? @values) (unless (list? @values)
(raise-argument-error '+xenum "list of values" @values)) (raise-argument-error 'x:enum "list of values" @values))
(define/augment (x:decode port parent) (define/augment (x:decode port parent)
(define index (send @type x:decode port parent)) (define index (send @type x:decode port parent))
(or (list-ref @values index) index)) (or (list-ref @values index) index))
(define/augment (x:encode val port [parent #f]) (define/augment (x:encode val port [parent #f])
(define index (index-of @values val)) (match (index-of @values val)
(unless index [(? values idx) (send @type x:encode idx port parent)]
(raise-argument-error 'xenum-encode "valid option" val)) [_ (raise-argument-error 'x:enum-encode "valid option" val)]))
(send @type x:encode index port parent))
(define/augment (x:size [val #f] [parent #f]) (define/augment (x:size [val #f] [parent #f])
(send @type x:size val parent)))) (send @type x:size val parent))))

10
xenomorph/xenomorph/optional.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require "helper.rkt" racket/class) (require "helper.rkt" racket/class racket/match)
(provide (all-defined-out)) (provide (all-defined-out))
#| #|
@ -13,11 +13,12 @@ https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
(init-field [(@type type)] [(@condition condition)]) (init-field [(@type type)] [(@condition condition)])
(unless (xenomorphic-type? @type) (unless (xenomorphic-type? @type)
(raise-argument-error '+xoptional"xenomorphic type" @type)) (raise-argument-error 'x:optional"xenomorphic type" @type))
(define (resolve-condition parent) (define (resolve-condition parent)
(define maybe-proc @condition) (match @condition
(if (procedure? maybe-proc) (maybe-proc parent) maybe-proc)) [(? procedure? proc) (proc parent)]
[val val]))
(define/augment (x:decode port parent) (define/augment (x:decode port parent)
(when (resolve-condition parent) (when (resolve-condition parent)
@ -30,7 +31,6 @@ https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
(define/augment (x:size [val #f] [parent #f]) (define/augment (x:size [val #f] [parent #f])
(if (resolve-condition parent) (send @type x:size val parent) 0)))) (if (resolve-condition parent) (send @type x:size val parent) 0))))
(define no-val (gensym)) (define no-val (gensym))
(define (x:optional [type-arg #f] [cond-arg no-val] (define (x:optional [type-arg #f] [cond-arg no-val]
#:type [type-kwarg #f] #:type [type-kwarg #f]

4
xenomorph/xenomorph/pointer.rkt
Unescape Escape View File

@ -21,7 +21,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
(cond (cond
[type (values type val)] [type (values type val)]
[(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))] [(xvoid-pointer? val) (values (xvoid-pointer-type val) (xvoid-pointer-value val))]
[else (raise-argument-error 'Pointer:size "VoidPointer" val)])) [else (raise-argument-error 'x:pointer "VoidPointer" val)]))
(define x:pointer% (define x:pointer%
(class xenobase% (class xenobase%
@ -36,7 +36,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
(define/augment (x:decode port parent) (define/augment (x:decode port parent)
(define offset (send @offset-type x:decode port parent)) (define offset (send @offset-type x:decode port parent))
(cond (cond
[(and @allow-null? (= offset @null-value)) #f] ; handle null pointers [(and @allow-null? (= offset @null-value)) #false] ; handle null pointers
[else [else
(define relative (+ (case @pointer-relative-to (define relative (+ (case @pointer-relative-to
[(local) (hash-ref parent x:start-offset-key)] [(local) (hash-ref parent x:start-offset-key)]

16
xenomorph/xenomorph/string.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require racket/class racket/dict "helper.rkt" "util.rkt" "number.rkt") (require racket/class racket/match "helper.rkt" "util.rkt" "number.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
#| #|
@ -40,9 +40,9 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
(define/augment (x:decode port parent) (define/augment (x:decode port parent)
(define len (or (resolve-length @len port parent) (count-nonzero-chars port))) (define len (or (resolve-length @len port parent) (count-nonzero-chars port)))
(define encoding (if (procedure? @encoding) (define encoding (match @encoding
(or (@encoding parent) 'ascii) [(? procedure? proc) (or (proc parent) 'ascii)]
@encoding)) [enc enc]))
(define adjustment (if (and (not @len) (bytes-left-in-port? port)) 1 0)) (define adjustment (if (and (not @len) (bytes-left-in-port? port)) 1 0))
(begin0 (begin0
(decode-string len port encoding) (decode-string len port encoding)
@ -50,16 +50,16 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee
(define/augment (x:encode val-arg port [parent #f]) (define/augment (x:encode val-arg port [parent #f])
(define val (if (string? val-arg) val-arg (format "~a" val-arg))) (define val (if (string? val-arg) val-arg (format "~a" val-arg)))
(define encoding (if (procedure? @encoding) (define encoding (match @encoding
(or (@encoding (and parent (hash-ref parent val)) 'ascii)) [(? procedure?) (@encoding (and parent (hash-ref parent val)) 'ascii)]
@encoding)) [enc enc]))
(define encoded-str (encode-string val encoding)) (define encoded-str (encode-string val encoding))
(define encoded-length (bytes-length encoded-str)) (define encoded-length (bytes-length encoded-str))
(when (and (exact-nonnegative-integer? @len) (> encoded-length @len)) (when (and (exact-nonnegative-integer? @len) (> encoded-length @len))
(raise-argument-error 'xstring-encode (format "string no longer than ~a" @len) val)) (raise-argument-error 'xstring-encode (format "string no longer than ~a" @len) val))
(when (x:int? @len) (when (x:int? @len)
(send @len x:encode encoded-length port parent)) (send @len x:encode encoded-length port parent))
(define string-terminator (if (not @len) (bytes 0) (bytes))) ; null terminated when no len (define string-terminator (if @len (bytes) (bytes 0))) ; null terminated when no len
(bytes-append encoded-str string-terminator)) (bytes-append encoded-str string-terminator))
(define/augment (x:size [val-arg #f] [parent #f]) (define/augment (x:size [val-arg #f] [parent #f])

10
xenomorph/xenomorph/struct.rkt
Unescape Escape View File

@ -2,6 +2,7 @@
(require racket/dict (require racket/dict
racket/class racket/class
racket/sequence racket/sequence
racket/match
racket/list racket/list
"helper.rkt" "helper.rkt"
"number.rkt" "number.rkt"
@ -27,9 +28,9 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(unless (assocs? fields) (unless (assocs? fields)
(raise-argument-error 'x:struct-parse-fields "assocs" fields)) (raise-argument-error 'x:struct-parse-fields "assocs" fields))
(for ([(key type) (in-dict fields)]) (for ([(key type) (in-dict fields)])
(define val (if (procedure? type) (define val (match type
(type mheq) [(? procedure? proc) (proc mheq)]
(send type x:decode port mheq))) [_ (send type x:decode port mheq)]))
(unless (void? val) (unless (void? val)
(hash-set! mheq key val)) (hash-set! mheq key val))
(hash-set! mheq x:current-offset-key (- (pos port) (hash-ref mheq x:start-offset-key)))) (hash-set! mheq x:current-offset-key (- (pos port) (hash-ref mheq x:start-offset-key))))
@ -74,7 +75,8 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
(for ([(key type) (in-dict @fields)]) (for ([(key type) (in-dict @fields)])
(send type x:encode (dict-ref field-data key) port parent)) (send type x:encode (dict-ref field-data key) port parent))
(for ([ptr (in-list (hash-ref parent x:pointers-key))]) (for ([ptr (in-list (hash-ref parent x:pointers-key))])
(send (x:ptr-type ptr) x:encode (x:ptr-val ptr) port (x:ptr-parent ptr)))) (match ptr
[(x:ptr type val parent) (send type x:encode val port parent)])))
(define/augride (x:size [val #f] [parent-arg #f] [include-pointers #t]) (define/augride (x:size [val #f] [parent-arg #f] [include-pointers #t])
(define parent (mhasheq x:parent-key parent-arg (define parent (mhasheq x:parent-key parent-arg

16
xenomorph/xenomorph/util.rkt
Unescape Escape View File

@ -1,15 +1,15 @@
#lang racket/base #lang racket/base
(require racket/dict "number.rkt" "helper.rkt" "generic.rkt") (require racket/match racket/dict "number.rkt" "helper.rkt" "generic.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(define (length-resolvable? x) (define (length-resolvable? x)
(or (not x) (symbol? x) (xenomorphic? x) (procedure? x) (exact-nonnegative-integer? x))) (or (not x) (symbol? x) (xenomorphic? x) (procedure? x) (exact-nonnegative-integer? x)))
(define (resolve-length x port [parent #f]) (define (resolve-length x port [parent #f])
(cond (match x
[(not x) #f] [#false #false]
[(exact-nonnegative-integer? x) x] [(? exact-nonnegative-integer?) x]
[(procedure? x) (x parent)] [(? procedure? proc) (proc parent)]
[(and parent (symbol? x)) (dict-ref parent x)] [(? symbol? key) #:when parent (dict-ref parent key)]
[(and port (x:int? x)) (decode x port)] [(? x:int?) #:when port (decode x port)]
[else (raise-argument-error 'resolve-length "fixed-size argument" x)])) [_ (raise-argument-error 'resolve-length "fixed-size argument" x)]))

62
xenomorph/xenomorph/versioned-struct.rkt
Unescape Escape View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require "helper.rkt" "struct.rkt" (require "helper.rkt" "struct.rkt"
racket/dict racket/dict
racket/match
racket/class racket/class
sugar/unstable/dict) sugar/unstable/dict)
(provide (all-defined-out)) (provide (all-defined-out))
@ -21,14 +22,6 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(unless (and (dict? @versions) (andmap (λ (v) (or (dict? v) (x:struct? v))) (dict-values @versions))) (unless (and (dict? @versions) (andmap (λ (v) (or (dict? v) (x:struct? v))) (dict-values @versions)))
(raise-argument-error 'x:versioned-struct "dict of dicts or structish" @versions)) (raise-argument-error 'x:versioned-struct "dict of dicts or structish" @versions))
(define version-getter (cond
[(procedure? @type) @type]
[(symbol? @type) (λ (parent) (dict-ref parent @type))]))
(define version-setter (cond
[(procedure? @type) @type]
[(symbol? @type) (λ (parent version) (dict-set! parent @type version))]))
(define (select-field-set val) (define (select-field-set val)
(define version-key (define version-key
(or (dict-ref val x:version-key #f) (or (dict-ref val x:version-key #f)
@ -40,26 +33,28 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(define/override (x:decode port parent [length 0]) (define/override (x:decode port parent [length 0])
(define res (setup-private-fields port parent length)) (define res (setup-private-fields port parent length))
(define which-version (cond (define which-version (match @type
[(integer? @type) @type] [(? integer? int) int]
[(or (symbol? @type) (procedure? @type)) [(? symbol? key) #:when parent (dict-ref parent key)]
(unless parent [(? procedure? proc) #:when parent (proc parent)]
(raise-argument-error 'x:versioned-struct-decode "valid parent" parent)) [(or (? symbol?) (? procedure?))
(version-getter parent)] (raise-argument-error 'x:versioned-struct-decode "valid parent" parent)]
[else (send @type x:decode port parent)])) [_ (send @type x:decode port parent)]))
(dict-set! res x:version-key which-version) (dict-set! res x:version-key which-version)
(define maybe-header-val (dict-ref @versions 'header #f)) (cond
(when maybe-header-val [(dict-ref @versions 'header #f)
(parse-fields port res maybe-header-val)) => (λ (header-val) (parse-fields port res header-val))])
(define field-object (define field-object
(or (dict-ref @versions which-version #f) (cond
(raise-argument-error 'x:versioned-struct-decode (format "valid field version: ~v" (dict-keys @versions)) which-version))) [(dict-ref @versions which-version #f) => values]
[else
(if (x:versioned-struct? field-object) (raise-argument-error 'x:versioned-struct-decode (format "valid field version: ~v" (dict-keys @versions)) which-version)]))
(send field-object x:decode port parent)
(parse-fields port res field-object))) (match field-object
[(? x:versioned-struct?) (send field-object x:decode port parent)]
[_ (parse-fields port res field-object)]))
(define/override (x:encode field-data port [parent-arg #f]) (define/override (x:encode field-data port [parent-arg #f])
(unless (dict? field-data) (unless (dict? field-data)
@ -76,12 +71,13 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
(send type x:encode (dict-ref field-data key) port parent)) (send type x:encode (dict-ref field-data key) port parent))
(define fields (select-field-set field-data)) (define fields (select-field-set field-data))
(unless (andmap (λ (key) (member key (dict-keys field-data))) (dict-keys fields)) (unless (andmap (λ (key) (member key (hash-keys field-data))) (dict-keys fields))
(raise-argument-error 'x:versioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys field-data))) (raise-argument-error 'x:versioned-struct-encode (format "hash that contains superset of xversioned-struct keys: ~a" (dict-keys fields)) (hash-keys field-data)))
(for ([(key type) (in-dict fields)]) (for ([(key type) (in-dict fields)])
(send type x:encode (dict-ref field-data key) port parent)) (send type x:encode (hash-ref field-data key) port parent))
(for ([ptr (in-list (dict-ref parent x:pointers-key))]) (for ([ptr (in-list (hash-ref parent x:pointers-key))])
(send (x:ptr-type ptr) x:encode (x:ptr-val ptr) port (x:ptr-parent ptr)))) (match ptr
[(x:ptr type val parent) (send type x:encode val port parent)])))
(define/override (x:size [val #f] [parent-arg #f] [include-pointers #t]) (define/override (x:size [val #f] [parent-arg #f] [include-pointers #t])
(unless val (unless val
@ -90,12 +86,12 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
x:val-key val x:val-key val
x:pointer-size-key 0)) x:pointer-size-key 0))
(define version-size (define version-size
(let ([struct-type @type]) (match @type
(if (or (symbol? struct-type) (procedure? struct-type)) [(or (? symbol?) (? procedure?)) 0]
0 [_ (send @type x:size (dict-ref val x:version-key) parent)]))
(send @type x:size (dict-ref val x:version-key) parent))))
(define header-size (define header-size
(for/sum ([(key type) (in-dict (or (dict-ref @versions 'header #f) null))]) (for/sum ([(key type) (in-dict (dict-ref @versions 'header null))])
(send type x:size (and val (dict-ref val key)) parent))) (send type x:size (and val (dict-ref val key)) parent)))
(define fields-size (define fields-size
(for/sum ([(key type) (in-dict (select-field-set val))]) (for/sum ([(key type) (in-dict (select-field-set val))])

Write Preview
Loading…
Cancel
Save