|
|
|
@ -8,46 +8,48 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
(define-subclass Struct (VersionedStruct type [versions (dictify)])
|
|
|
|
|
|
|
|
|
|
(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)
|
|
|
|
|
(inherit-field fields)
|
|
|
|
|
(field [forced-version #f])
|
|
|
|
|
(field [forced-version #f]
|
|
|
|
|
[versionGetter void]
|
|
|
|
|
[versionSetter void])
|
|
|
|
|
|
|
|
|
|
(define/public-final (force-version! version)
|
|
|
|
|
(set! forced-version version))
|
|
|
|
|
(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))))
|
|
|
|
|
|
|
|
|
|
(define/override (decode stream [parent #f] [length 0])
|
|
|
|
|
(define res (_setup stream parent length))
|
|
|
|
|
|
|
|
|
|
(define/public (resolve-version [stream #f] [parent #f])
|
|
|
|
|
(ref-set! res 'version
|
|
|
|
|
(cond
|
|
|
|
|
[forced-version] ; for testing purposes: pass an explicit version
|
|
|
|
|
[(integer? type) type]
|
|
|
|
|
[(symbol? type)
|
|
|
|
|
;; find the first Struct in the chain of ancestors
|
|
|
|
|
;; with the target key
|
|
|
|
|
(let loop ([x parent])
|
|
|
|
|
(cond
|
|
|
|
|
[(and x (Struct? x) (dict-ref (· x res) type #f))]
|
|
|
|
|
[(· x parent) => loop]
|
|
|
|
|
[else #f]))]
|
|
|
|
|
[(and (procedure? type) (positive? (procedure-arity type))) (type parent)]
|
|
|
|
|
[(RestructureBase? type) (send type decode stream)]
|
|
|
|
|
[else (raise-argument-error 'VersionedStruct:resolve-version "way of finding version" type)]))
|
|
|
|
|
[(symbol? type) (unless parent
|
|
|
|
|
(raise-argument-error 'VersionedStruct:decode "valid parent" parent))
|
|
|
|
|
(versionGetter parent)]
|
|
|
|
|
[else (send type decode stream)]))
|
|
|
|
|
|
|
|
|
|
(when (dict-ref versions 'header #f)
|
|
|
|
|
(_parseFields stream res (ref versions 'header)))
|
|
|
|
|
|
|
|
|
|
(define fields (dict-ref versions (ref res 'version) (λ () (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions))))))
|
|
|
|
|
|
|
|
|
|
(define/override (decode stream [parent #f] [length 0])
|
|
|
|
|
(set! res (send this _setup stream parent length))
|
|
|
|
|
(report res 'versioned-struct-res)
|
|
|
|
|
(define version (resolve-version stream parent))
|
|
|
|
|
(hash-set! res 'version version)
|
|
|
|
|
(define fields (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions))))))
|
|
|
|
|
(cond
|
|
|
|
|
[(VersionedStruct? fields) (send fields decode stream parent)]
|
|
|
|
|
[else
|
|
|
|
|
(report res 'whatigot)
|
|
|
|
|
(send this _parseFields stream res fields)
|
|
|
|
|
(send this process res stream)
|
|
|
|
|
(_parseFields stream res fields)
|
|
|
|
|
(process res stream)
|
|
|
|
|
res]))
|
|
|
|
|
|
|
|
|
|
(define/public-final (force-version! version)
|
|
|
|
|
(set! forced-version version))
|
|
|
|
|
|
|
|
|
|
(define/override (encode stream input-hash [parent #f])
|
|
|
|
|
(unless (hash? input-hash)
|
|
|
|
|
(raise-argument-error 'Struct:encode "hash" input-hash))
|
|
|
|
@ -66,20 +68,35 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
|
|
|
|
|
[else (send fields encode stream input-hash parent)]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define/override (size [input-hash (mhash)] [parent #f] [includePointers #t])
|
|
|
|
|
(when (and (not input-hash) (not forced-version))
|
|
|
|
|
(define/override (size [val (mhash)] [parent #f] [includePointers #t])
|
|
|
|
|
(unless (or val forced-version)
|
|
|
|
|
(error 'VersionedStruct-cannot-compute-size))
|
|
|
|
|
(define version (resolve-version #f parent))
|
|
|
|
|
(define fields (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:size "valid version key" version))))
|
|
|
|
|
(cond
|
|
|
|
|
[(dict? fields)
|
|
|
|
|
(for/sum ([(key type) (in-dict fields)])
|
|
|
|
|
(define val (hash-ref input-hash key #f))
|
|
|
|
|
(define args (if val (list val) empty))
|
|
|
|
|
(send type size . args))]
|
|
|
|
|
[else (send fields size input-hash parent includePointers)])))
|
|
|
|
|
|
|
|
|
|
(test-module
|
|
|
|
|
(define ctx (mhash 'parent parent
|
|
|
|
|
'val val
|
|
|
|
|
'pointerSize 0))
|
|
|
|
|
|
|
|
|
|
(define size 0)
|
|
|
|
|
(when (not (string? 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 (dict-ref versions (ref val 'version) (λ () (raise-argument-error 'VersionedStruct:encode "valid version key" version))))
|
|
|
|
|
|
|
|
|
|
(increment! size
|
|
|
|
|
(for/sum ([(key type) (in-dict (ref versions 'header))])
|
|
|
|
|
(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)))
|
|
|
|
|