version key problem

7 years ago · 1cf9abeb26
parent baffeb6323
commit 1cf9abeb26
5 changed files with 87 additions and 83 deletions
--- a/pitfall/fontkit/GPOS.rkt
+++ b/pitfall/fontkit/GPOS.rkt
@ -100,7 +100,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/GPOS.js
 (define-subclass VersionedStruct (GPOSLookup-VersionedStruct))
 (define GPOSLookup
  (+GPOSLookup-VersionedStruct
-   'lookupType
+   (λ (parent) (or (· parent parent res lookupType)
+                   (raise-argument-error 'GPOSLookup "parent object" #f)))
   (dictify
    ;; Single Adjustment
    1 (+VersionedStruct uint16be
@ -184,15 +185,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/GPOS.js
 ;; Fix circular reference
 ;; GPOSLookup.versions[9].extension.type = GPOSLookup;

-(define gpos-common-dict (dictify 'scriptList (+Pointer uint16be ScriptList) ; pointer
-                                  'featureList (+Pointer uint16be FeatureList) ; pointer
-                                  'lookupList (+Pointer uint16be (LookupList GPOSLookup))
-                                  )) ; pointer
+(define gpos-common-dict (dictify 'scriptList (+Pointer uint16be ScriptList)
+                                  'featureList (+Pointer uint16be FeatureList)
+                                  'lookupList (+Pointer uint16be (LookupList GPOSLookup))))

 (define-subclass VersionedStruct (GPOS-VersionedStruct))
 (define GPOS (+GPOS-VersionedStruct uint32be
-                               (dictify
-                                #x00010000 gpos-common-dict
-                                #x00010001 (append gpos-common-dict (dictify 'featureVariations uint32be))))) ; pointer
+                                    (dictify
+                                     #x00010000 gpos-common-dict
+                                     ;; ignore variations
+                                     #;#x00010001 #;(append gpos-common-dict (dictify 'featureVariations (+Pointer uint32be FeatureVariations))))))

 (test-module)
--- a/pitfall/fontkit/opentype.rkt
+++ b/pitfall/fontkit/opentype.rkt
@ -47,16 +47,15 @@
 (define LookupFlags (+Bitfield uint16be '(rightToLeft ignoreBaseGlyphs ignoreLigatures ignoreMarks useMarkFilteringSet #f markAttachmentType)))

 (define (LookupList SubTable)
-  (+Array ; originally LazyArray
-   (+Pointer uint16be (+Struct
-                       (dictify
-                        'lookupType uint16be
-                        'flags LookupFlags
-                        'subTableCount uint16be
-                        ;; 'subTables (+Array (+Pointer uint16be SubTable) 'subTableCount)
-                        'subTables (+Array uint16be 'subTableCount)
-                        'markFilteringSet uint16be)))
-   uint16be))
+  (define Lookup (+Struct
+                  (dictify
+                   'lookupType uint16be
+                   'flags LookupFlags
+                   'subTableCount uint16be
+                   'subTables (+Array (+Pointer uint16be SubTable) 'subTableCount)
+                   ;'subTables (+Array uint16be 'subTableCount)
+                   'markFilteringSet uint16be)))
+  (+Array (+Pointer uint16be Lookup) uint16be))

 ;;#############################################
 ;; Contextual Substitution/Positioning Tables #
--- a/pitfall/restructure/base.rkt
+++ b/pitfall/restructure/base.rkt
@ -10,7 +10,6 @@
    (define/pubment (decode stream . args)
      (set! starting-offset (and (object? stream) (send stream pos)))
      (set! parent (and (pair? args) (is-a? (car args) RestructureBase) (car args)))
-      #;(report* starting-offset parent (and parent (get-field starting-offset parent)))
      (inner (void) decode stream . args))
    (abstract encode)
    (abstract size)
--- a/pitfall/restructure/pointer.rkt
+++ b/pitfall/restructure/pointer.rkt
@ -12,12 +12,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
                              [else (raise-argument-error 'Pointer "local or parent" scope)]))

  (define/augride (decode stream ctx)
-    #;(report* (· this starting-offset) (· this parent starting-offset))
    (define offset (send offsetType decode stream ctx))
    (define ptr (+ offset (caseq scope
                                 [(local) (· this parent starting-offset)]
                                 [(parent) (· this parent parent starting-offset)])))
-    #;(report* offset ptr)
    (cond
      [type (define orig-pos (send stream pos))
            (send stream pos ptr)
--- a/pitfall/restructure/struct.rkt
+++ b/pitfall/restructure/struct.rkt
@ -7,68 +7,49 @@ approximates
 https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
 |#

-(define-subclass Streamcoder (Struct [assocs (dictify)])
+(define-subclass Streamcoder (Struct [fields (dictify)])
  (field [res #f])
  
-  (unless (assocs? assocs)
-    (raise-argument-error 'Struct "assocs" assocs))
-  (field [key-index #f] ; store the original key order
-         [fields (mhash)])
+  (unless ((disjoin assocs? VersionedStruct?) fields)
+    (raise-argument-error 'Struct "assocs or Versioned Struct" fields))

-  (define/private (update-key-index! assocs)
-    (unless (assocs? assocs)
-      (raise-argument-error 'Struct "assocs" assocs))
-    (set! key-index (map car assocs)))
-
-  (update-key-index! assocs)
-  
-  (define/public-final (update-fields! assocs)
-    (unless (assocs? assocs)
-      (raise-argument-error 'Struct "assocs or hash" assocs))
-    (update-key-index! assocs)
-    (for ([(k v) (in-dict assocs)])
-         (hash-set! fields k v)))
-  
-  (update-fields! assocs)
-  
  (define/augride (decode stream [parent #f] [length 0])
    (set! res (_setup stream parent length))
-    (_parseFields stream fields)
+    (_parseFields stream res fields)
    (send this process res stream)
    res)

-  (define/augment (encode stream input-hash [parent #f])
+  (define/augride (encode stream input-hash [parent #f])
    
    (unless (hash? input-hash)
      (raise-argument-error 'Struct:encode "hash" input-hash))

    (send this preEncode input-hash stream) ; preEncode goes first, because it might bring input hash into compliance

-    (inner (void) encode stream input-hash parent)
+    (unless (andmap (λ (key) (member key (hash-keys input-hash))) (dict-keys fields))
+      (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys input-hash)))

-    (unless (andmap (λ (key) (member key (hash-keys input-hash))) key-index)
-      (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" key-index) (hash-keys input-hash)))
-    
-    (for* ([key (in-list key-index)] ; iterate over original keys in order
-           [struct-type (in-value (hash-ref fields key))]
-           [value-to-encode (in-value (hash-ref input-hash key))])
-          (send struct-type encode stream value-to-encode)))
+    (cond
+      [(dict? fields)
+       (for* ([(key type) (in-dict fields)])
+             (send type encode stream (hash-ref input-hash key)))]
+      [else (send fields encode stream input-hash parent)]))

  (define/public-final (_setup stream parent length)
    (mhasheq))

-  (define/public-final (_parseFields stream fields)
-    (for ([key (in-list key-index)])         
-         (define dictvalue (dict-ref fields key))
+  (define/public-final (_parseFields stream res fields)
+    (unless (assocs? fields)
+      (raise-argument-error '_parseFields "assocs" fields))
+    (for ([(key type) (in-dict fields)])
         (define val
-           (if (procedure? dictvalue)
-               (dictvalue res)
-               (send dictvalue decode stream this)))
+           (if (procedure? type)
+               (type res)
+               (send type decode stream this)))
         (hash-set! res key val)))

-  (define/overment (size [input-hash (mhash)] [parent #f] [includePointers #t])
-    (inner (void) size input-hash parent includePointers)
-    (for/sum ([(key type) (in-hash fields)])
+  (define/override (size [input-hash (mhash)] [parent #f] [includePointers #t])
+    (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))))
@ -80,8 +61,8 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
 (check-exn exn:fail:contract? (λ () (+Struct 42)))

 ;; make random structs and make sure we can round trip
- (for ([i (in-range 100)])
-      (define field-types (for/list ([i (in-range 200)])
+ (for ([i (in-range 10)])
+      (define field-types (for/list ([i (in-range 20)])
                                    (random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
      (define size-num-types (for/sum ([num-type (in-list field-types)])
                                      (send num-type size)))
@ -101,13 +82,13 @@ approximates
 https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
 |#

-(define-subclass Struct (VersionedStruct version-resolver [versions (dictify)])
+(define-subclass Struct (VersionedStruct type [versions (dictify)])
  (inherit-field res)
-  (unless ((disjoin integer? procedure? RestructureBase? symbol?) version-resolver)
-    (raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" version-resolver))
+  (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-field fields key-index)
+  (inherit-field fields)
  (field [forced-version #f])
  
  (define/public-final (force-version! version)
@ -116,34 +97,54 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
  (define/public (resolve-version [stream #f] [parent #f])
    (cond
      [forced-version] ; for testing purposes: pass an explicit version
-      [(integer? version-resolver) version-resolver]
-      [(symbol? version-resolver) (hash-ref (· parent res) version-resolver)]
-      [(and (procedure? version-resolver) (positive? (procedure-arity version-resolver))) (version-resolver parent)]
-      [(RestructureBase? version-resolver) (send version-resolver decode stream)]
-      [else (raise-argument-error 'VersionedStruct:resolve-version "way of finding version" version-resolver)]))
+      [(integer? type) type]
+      [(symbol? type) (hash-ref (· parent res version-resolver))]
+      [(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)]))
  
  (define/override (decode stream [parent #f] [length 0])
    (set! res (send this _setup stream parent length))
    (define version (resolve-version stream parent))
    (hash-set! res 'version version)
-    (define assocs (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:decode "valid version key" version))))
-    (send this update-fields! assocs)
+    (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
-       (send this _parseFields stream fields)
+       (send this _parseFields stream res fields)
       (send this process res stream)
       res]))

-  (define/augment (encode stream input-hash [parent #f])
-    (define assocs (dict-ref versions (· input-hash version) (λ () (raise-argument-error 'VersionedStruct:encode "valid version key" version))))
-    (send this update-fields! assocs))
-  
+  (define/override (encode stream input-hash [parent #f])
+    (unless (hash? input-hash)
+      (raise-argument-error 'Struct:encode "hash" input-hash))

-  (define/augment (size [val (mhash)] [parent #f] [includePointers #t])
+    (send this preEncode input-hash stream) ; preEncode goes first, because it might bring input hash into compliance
+
+    (define fields (dict-ref versions (· input-hash version) (λ () (raise-argument-error 'VersionedStruct:encode "valid version key" version))))
+
+    (unless (andmap (λ (key) (member key (hash-keys input-hash))) (dict-keys fields))
+      (raise-argument-error 'Struct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys input-hash)))
+
+    (cond
+      [(dict? fields)
+       (for* ([(key type) (in-dict fields)])
+             (send type encode stream (hash-ref input-hash key)))]
+      [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))
+      (error 'VersionedStruct-cannot-compute-size))
    (define version (resolve-version #f parent))
-    (define assocs (dict-ref versions version (λ () (raise-argument-error 'VersionedStruct:size "valid version key" version))))
-    (send this update-fields! assocs)))
+    (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
 (require "number.rkt")
@ -168,6 +169,12 @@ https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
 (define s (+Struct (dictify 'a uint8 'b uint8 'c uint8)))
 (check-equal? (send s size) 3)
 (define vs (+VersionedStruct (λ (p) 2) (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s))))
- (check-equal? (send vs size) 6))
+ (check-equal? (send vs size) 6)
+ (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)
+
+ )