You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/pitfall/restructure/versioned-struct.rkt

151 lines
5.7 KiB
Racket

#lang restructure/racket
(require racket/dict "struct.rkt")
(provide (all-defined-out))
7 years ago
#|
approximates
https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
|#
(define-subclass Struct (VersionedStruct type [versions (dictify)])
7 years ago
(unless ((disjoin integer? procedure? RestructureBase? symbol?) type)
(raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" type))
(unless (and (dict? versions) (andmap (λ (val) (or (dict? val) (Struct? val))) (map cdr versions)))
(raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions))
(inherit _setup _parseFields process)
7 years ago
(inherit-field fields)
(field [forced-version #f]
[versionGetter void]
[versionSetter void])
(when (symbol? type) ; instead of string
(set-field! versionGetter this (λ (parent) (ref parent type)))
(set-field! versionSetter this (λ (parent version) (ref-set! parent type version))))
7 years ago
(define/override (decode stream [parent #f] [length 0])
(define res (_setup stream parent length))
(ref-set! res 'version
(cond
[forced-version] ; for testing purposes: pass an explicit version
[(symbol? type) (unless parent
(raise-argument-error 'VersionedStruct:decode "valid parent" parent))
(versionGetter parent)]
[else (send type decode stream)]))
(when (ref versions 'header)
(_parseFields stream res (ref versions 'header)))
(define fields (or (ref versions (ref res 'version)) (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions)))))
7 years ago
(cond
[(VersionedStruct? fields) (send fields decode stream parent)]
[else
(_parseFields stream res fields)
(process res stream)
7 years ago
res]))
(define/public-final (force-version! version)
(set! forced-version version))
7 years ago
(define/override (encode stream val [parent #f])
(unless (hash? val)
(raise-argument-error 'Struct:encode "hash" val))
7 years ago
(send this preEncode val stream) ; preEncode goes first, because it might bring input hash into compliance
7 years ago
(define ctx (mhash 'pointers empty
'startOffset (· stream pos)
'parent parent
'val val
'pointerSize 0))
7 years ago
(ref-set! ctx 'pointerOffset (+ (· stream pos) (size val ctx #f)))
7 years ago
(when (not (symbol? type))
(send type encode stream (· val version)))
(when (ref versions 'header)
(for ([(key type) (in-dict (ref versions 'header))])
(send type encode stream (ref val key) ctx)))
(define fields (or (ref versions (· val version)) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
(unless (andmap (λ (key) (member key (ref-keys val))) (ref-keys fields))
(raise-argument-error 'VersionedStruct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
(for ([(key type) (in-dict fields)])
(send type encode stream (ref val key) ctx))
(for ([ptr (in-list (ref ctx 'pointers))])
(send (ref ptr 'type) encode stream (ref ptr 'val) (ref ptr 'parent))))
7 years ago
(define/override (size [val (mhash)] [parent #f] [includePointers #t])
(unless (or val forced-version)
7 years ago
(error 'VersionedStruct-cannot-compute-size))
(define ctx (mhash 'parent parent
'val val
'pointerSize 0))
(define size 0)
(when (not (symbol? type))
(increment! size (send type size (ref val 'version) ctx)))
(when (ref versions 'header)
(increment! size
(for/sum ([(key type) (in-dict (ref versions 'header))])
(send type size (ref val key) ctx))))
(define fields (or (ref versions (ref val 'version)) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
(increment! size
(for/sum ([(key type) (in-dict fields)])
(send type size (ref val key) ctx)))
(when includePointers
(increment! size (ref ctx 'pointerSize)))
size))
#;(test-module
(require "number.rkt")
(define (random-pick xs) (list-ref xs (random (length xs))))
(check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42)))
;; make random versioned structs and make sure we can round trip
7 years ago
#;(for ([i (in-range 1)])
(define field-types (for/list ([i (in-range 1)])
(random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
(define num-versions 20)
(define which-struct (random num-versions))
(define struct-versions (for/list ([v (in-range num-versions)])
(cons v (for/list ([num-type (in-list field-types)])
(cons (gensym) num-type)))))
(define vs (+VersionedStruct which-struct struct-versions))
7 years ago
(report* vs (send vs size))
(error 'stop)
(define struct-size (for/sum ([num-type (in-list (map cdr (ref struct-versions which-struct)))])
(send num-type size)))
(define bs (apply bytes (for/list ([i (in-range struct-size)])
(random 256))))
(check-equal? (send vs encode #f (send vs decode bs)) bs))
(define s (+Struct (dictify 'a uint8 'b uint8 'c uint8)))
(check-equal? (send s size) 3)
7 years ago
(define vs (+VersionedStruct uint8 (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s))))
(send vs force-version! 1)
(check-equal? (send vs size) 6)
7 years ago
#|
(define s2 (+Struct (dictify 'a vs)))
(check-equal? (send s2 size) 6)
(define vs2 (+VersionedStruct (λ (p) 2) (dictify 1 vs 2 vs)))
(check-equal? (send vs2 size) 6)
7 years ago
|#
)
7 years ago