From 3aba76f33827d5019a47b937424474e19e16e745 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 5 Jul 2017 15:08:53 -0700 Subject: [PATCH] pass test14 --- pitfall/fontkit/GPOS-test.rkt | 9 +- pitfall/fontkit/OS2.rkt | 2 +- pitfall/fontkit/directory.rkt | 6 +- pitfall/fontkit/font.rkt | 4 +- pitfall/fontkit/gpos-processor-test.rkt | 31 +++++++ pitfall/fontkit/hhea.rkt | 5 +- pitfall/fontkit/hmtx.rkt | 4 +- pitfall/fontkit/layout-engine.rkt | 1 + pitfall/fontkit/opentype.rkt | 6 +- pitfall/fontkit/ot-layout-engine.rkt | 7 +- pitfall/fontkit/ot-processor.rkt | 26 +++--- pitfall/fontkit/racket.rkt | 4 +- pitfall/fontkit/script.rkt | 4 +- pitfall/fontkit/subset.rkt | 8 +- pitfall/pitfall/alltest.rkt | 2 +- pitfall/pitfall/test/test14.rkt | 3 +- pitfall/pitfall/test/test14rkt.pdf | Bin 0 -> 6287 bytes pitfall/sugar/class.rkt | 16 ++-- pitfall/sugar/js.rkt | 5 +- pitfall/xenomorph/private/base.rkt | 32 +++---- pitfall/xenomorph/private/string.rkt | 56 ++++++++----- pitfall/xenomorph/private/struct.rkt | 56 +++++++------ pitfall/xenomorph/test/struct-test.rkt | 10 +-- .../xenomorph/test/versioned-struct-test.rkt | 78 +++++++++--------- 24 files changed, 222 insertions(+), 153 deletions(-) create mode 100644 pitfall/fontkit/gpos-processor-test.rkt diff --git a/pitfall/fontkit/GPOS-test.rkt b/pitfall/fontkit/GPOS-test.rkt index 2cbc33de..2c9fac2b 100644 --- a/pitfall/fontkit/GPOS-test.rkt +++ b/pitfall/fontkit/GPOS-test.rkt @@ -1,8 +1,13 @@ #lang fontkit/racket -(require fontkit "subset.rkt" rackunit xenomorph racket/serialize) +(require fontkit fontkit/gpos-processor "subset.rkt" rackunit xenomorph racket/serialize) (define fira-path "../pitfall/test/assets/fira.ttf") (define f (openSync fira-path)) (define gpos (· f GPOS)) -(get (· gpos lookupList) 11) +#;(get (· gpos lookupList) 11) + +(define gp (+GPOSProcessor f gpos)) + +(· gpos scriptList) +(send gp selectScript 'cyrl) diff --git a/pitfall/fontkit/OS2.rkt b/pitfall/fontkit/OS2.rkt index f26ca711..0a561e9e 100644 --- a/pitfall/fontkit/OS2.rkt +++ b/pitfall/fontkit/OS2.rkt @@ -50,7 +50,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/OS2.js 'sFamilyClass int16be ;; classification of font-family design 'panose (+Array uint8 10) ;; describe the visual characteristics of a given typeface 'ulCharRange (+Array uint32be 4) - 'vendorID (+String 4) ;; four character identifier for the font vendor + 'vendorID (+Symbol 4) ;; four character identifier for the font vendor ;; bit field containing information about the font 'fsSelection (+Bitfield uint16 '(italic underscore negative outlined strikeout bold regular useTypoMetrics wws oblique)) 'usFirstCharIndex uint16be ;; The minimum Unicode index in this font diff --git a/pitfall/fontkit/directory.rkt b/pitfall/fontkit/directory.rkt index bf9fce3f..b8906d1d 100644 --- a/pitfall/fontkit/directory.rkt +++ b/pitfall/fontkit/directory.rkt @@ -8,7 +8,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js |# (define TableEntry (+Struct - (dictify 'tag (+String 4) + (dictify 'tag (+Symbol 4) 'checkSum uint32be 'offset (+Pointer uint32be 'void (mhash 'type 'global)) 'length uint32be))) @@ -39,7 +39,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js (define searchRange (* (floor (log numTables 2)) 16)) (hash-set*! this-val - 'tag "true" + 'tag 'true 'numTables numTables 'tables tables 'searchRange searchRange @@ -48,7 +48,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js this-val)) -(define Directory (+RDirectory (dictify 'tag (+String 4) +(define Directory (+RDirectory (dictify 'tag (+Symbol 4) 'numTables uint16be 'searchRange uint16be 'entrySelector uint16be diff --git a/pitfall/fontkit/font.rkt b/pitfall/fontkit/font.rkt index ddeff548..612ab1a9 100644 --- a/pitfall/fontkit/font.rkt +++ b/pitfall/fontkit/font.rkt @@ -235,8 +235,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/TTFFont.js (define/contract (layout this string [userFeatures #f] [script #f] [language #f]) ((string?) ((option/c (listof symbol?)) (option/c symbol?) (option/c symbol?)) . ->*m . GlyphRun?) (unless (· this _layoutEngine) - (set-field! _layoutEngine this (make-object LayoutEngine this))) - (report 'in-layout) + (set-field! _layoutEngine this (+LayoutEngine this))) + (report* 'in-layout (· this _layoutEngine)) (send (· this _layoutEngine) layout string userFeatures script language)) diff --git a/pitfall/fontkit/gpos-processor-test.rkt b/pitfall/fontkit/gpos-processor-test.rkt new file mode 100644 index 00000000..fc6b14f0 --- /dev/null +++ b/pitfall/fontkit/gpos-processor-test.rkt @@ -0,0 +1,31 @@ +#lang fontkit/racket +(require fontkit "gpos-processor.rkt" rackunit xenomorph racket/serialize describe) + +(define fira-path "../pitfall/test/assets/fira.ttf") +(define f (openSync fira-path)) +(define gpos (· f GPOS)) + +(define proc (+GPOSProcessor f gpos)) + +(check-equal? (dump (· proc features)) + '((cpsp (lookupCount . 1) (lookupListIndexes 0) (featureParams . 0)) + (mkmk (lookupCount . 5) (lookupListIndexes 8 9 10 11 12) (featureParams . 0)) + (mark (lookupCount . 3) (lookupListIndexes 5 6 7) (featureParams . 0)) + (kern (lookupCount . 4) (lookupListIndexes 1 2 3 4) (featureParams . 0)))) + +(check-equal? (dump (· proc script)) + '((count . 0) + (defaultLangSys (featureIndexes 0 14 28 42) + (reserved . 0) + (reqFeatureIndex . 65535) + (featureCount . 4)) + (langSysRecords))) +(check-equal? (dump (· proc scriptTag)) 'DFLT) +(check-equal? (dump (· proc language)) + '((featureIndexes 0 14 28 42) + (reserved . 0) + (reqFeatureIndex . 65535) + (featureCount . 4))) +(check-equal? (dump (· proc languageTag)) #f) +(check-equal? (dump (· proc lookups)) empty) +(check-equal? (dump (· proc direction)) 'ltr) diff --git a/pitfall/fontkit/hhea.rkt b/pitfall/fontkit/hhea.rkt index 0138f6eb..20692420 100644 --- a/pitfall/fontkit/hhea.rkt +++ b/pitfall/fontkit/hhea.rkt @@ -35,8 +35,5 @@ (define table-data (decode hhea table-bytes)) (check-equal? (· table-data ascent) 980) (check-equal? (· table-data descent) -238) - (check-equal? (· table-data numberOfMetrics) 229) - - - ) + (check-equal? (· table-data numberOfMetrics) 229)) diff --git a/pitfall/fontkit/hmtx.rkt b/pitfall/fontkit/hmtx.rkt index 5c2281f2..6e711222 100644 --- a/pitfall/fontkit/hmtx.rkt +++ b/pitfall/fontkit/hmtx.rkt @@ -37,8 +37,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/hmtx.js (define hmtx-data (decode hmtx-test hmtx-bytes)) (check-equal? (send hmtx-test size) (* 229 (send HmtxEntry size))) (define H-gid 41) (define OE-gid 142) - (check-equal? (dump (send (· hmtx-data metrics) get H-gid)) (mhasheq 'advance 738 'bearing 33)) - (check-equal? (dump (send (· hmtx-data metrics) get OE-gid)) (mhasheq 'advance 993 'bearing 43)) + (check-equal? (dump (send (· hmtx-data metrics) get H-gid)) '#hasheq((advance . 738) (bearing . 33))) + (check-equal? (dump (send (· hmtx-data metrics) get OE-gid)) '#hasheq((advance . 993) (bearing . 43))) ) \ No newline at end of file diff --git a/pitfall/fontkit/layout-engine.rkt b/pitfall/fontkit/layout-engine.rkt index 0a6b6d48..4d763580 100644 --- a/pitfall/fontkit/layout-engine.rkt +++ b/pitfall/fontkit/layout-engine.rkt @@ -18,6 +18,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/LayoutEngine.js (cond [(· this font has-morx-table?) (error 'morx-layout-unimplemented)] [(or (· this font has-gsub-table?) (· this font has-gpos-table?)) + (report/file 'starting-layout-engine) (+OTLayoutEngine (· this font))] [else #f])]) diff --git a/pitfall/fontkit/opentype.rkt b/pitfall/fontkit/opentype.rkt index 05a7b242..cf46e32d 100644 --- a/pitfall/fontkit/opentype.rkt +++ b/pitfall/fontkit/opentype.rkt @@ -21,7 +21,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/opentype.js (define-subclass Pointer (LSR-Pointer)) (define LangSysRecord (+Struct - (dictify 'tag (+String 4) + (dictify 'tag (+Symbol 4) 'langSys (+LSR-Pointer uint16be LangSysTable (mhash 'type 'parent))))) (define-subclass Pointer (DLS-Pointer)) @@ -34,7 +34,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/opentype.js (define-subclass Struct (ScriptRecord-Struct)) (define-subclass Pointer (ScriptRecord-Pointer)) (define ScriptRecord (+ScriptRecord-Struct - (dictify 'tag (+String 4) + (dictify 'tag (+Symbol 4) 'script (+ScriptRecord-Pointer uint16be Script (mhash 'type 'parent))))) (define ScriptList (+Array ScriptRecord uint16be)) @@ -52,7 +52,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/opentype.js (define-subclass Struct (FeatureRec)) (define-subclass Pointer (FeatureRec-Pointer)) (define FeatureRecord (+FeatureRec (dictify - 'tag (+String 4) + 'tag (+Symbol 4) 'feature (+FeatureRec-Pointer uint16be Feature (mhash 'type 'parent))))) (define FeatureList (+Array FeatureRecord uint16be)) diff --git a/pitfall/fontkit/ot-layout-engine.rkt b/pitfall/fontkit/ot-layout-engine.rkt index 3e214b84..dc61f821 100644 --- a/pitfall/fontkit/ot-layout-engine.rkt +++ b/pitfall/fontkit/ot-layout-engine.rkt @@ -12,10 +12,13 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTLayoutEngine.js [GSUBProcessor #f] [GPOSProcessor #f]) - (report 'dingdong) - (when (· font has-gsub-table?) + (report/file 'starting-ot-layout-engine) + ;; todo: gsub + #;(when (· font has-gsub-table?) (set-field! GSUBProcessor this (+GSUBProcessor font (· font GSUB)))) + + (report* 'starting-gpos-dingdong) (when (· font has-gpos-table?) (set-field! GPOSProcessor this (+GPOSProcessor font (· font GPOS)))) diff --git a/pitfall/fontkit/ot-processor.rkt b/pitfall/fontkit/ot-processor.rkt index 56da5098..087d86b4 100644 --- a/pitfall/fontkit/ot-processor.rkt +++ b/pitfall/fontkit/ot-processor.rkt @@ -15,7 +15,8 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js [language #f] [languageTag #f] [features (mhash)] - [lookups (mhash)]) + [lookups (mhash)] + [direction #f]) ; appears below ;; initialize to default script + language (selectScript) @@ -25,22 +26,20 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js [positions empty] ; only used by GPOS [ligatureID 1]) - (define/public (findScript script) - (unless (script? script) - (raise-argument-error 'findScript "script" script)) + (define/public (findScript script-or-scripts) (and (· this table scriptList) - (let ([script (if (not (list? script)) (list script) script)]) + (let ([scripts (if (pair? script-or-scripts) script-or-scripts (list script-or-scripts))]) (for*/first ([entry (in-list (· this table scriptList))] - [s (in-list script)] - #:when (equal? (· entry tag) s)) + [s (in-list scripts)] + #:when (eq? (· entry tag) s)) entry)))) - (define/public (selectScript script language) + (define/public (selectScript [script #f] [language #f]) (let/ec return! (define changed #f) (define entry #f) - (when (or (not (· this script)) (not (equal? script (· this scriptTag)))) + (when (or (not (· this script)) (not (eq? script (· this scriptTag)))) (set! entry (findScript script)) (when script (set! entry (findScript script))) ; ? why double dip @@ -69,11 +68,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/opentype/OTProcessor.js (set-field! features this (mhash)) (when (· this language) (for ([featureIndex (in-list (· this language featureIndexes))]) - (define record (hash-ref (· this table featureList) featureIndex)) - (hash-set! (· this features) (· record tag)) (· record feature)))))) - - - ) - - + (define record (list-ref (· this table featureList) featureIndex)) + (dict-set! (· this features) (· record tag) (· record feature)))))))) diff --git a/pitfall/fontkit/racket.rkt b/pitfall/fontkit/racket.rkt index af077b3b..9eadbe77 100644 --- a/pitfall/fontkit/racket.rkt +++ b/pitfall/fontkit/racket.rkt @@ -23,9 +23,9 @@ sugar/dict sugar/stub sugar/port - sugar/contract) + sugar/contract + describe) -(define script? symbol?) (module reader syntax/module-reader #:language 'fontkit/racket diff --git a/pitfall/fontkit/script.rkt b/pitfall/fontkit/script.rkt index 6169a011..7da1b071 100644 --- a/pitfall/fontkit/script.rkt +++ b/pitfall/fontkit/script.rkt @@ -141,7 +141,7 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/Script.js (define/contract (fromUnicode script) - ((option/c script?) . -> . script?) + ((option/c symbol?) . -> . symbol?) (hash-ref UNICODE_SCRIPTS script #f)) (define-stub-stop forString) @@ -178,5 +178,5 @@ https://github.com/mbutterick/fontkit/blob/master/src/layout/Script.js )) (define/contract (direction script) - ((option/c script?) . -> . (or/c 'rtl 'ltr)) + ((option/c symbol?) . -> . (or/c 'rtl 'ltr)) (if (memq script RTL) 'rtl 'ltr)) \ No newline at end of file diff --git a/pitfall/fontkit/subset.rkt b/pitfall/fontkit/subset.rkt index 5ee338c3..a5beeb34 100644 --- a/pitfall/fontkit/subset.rkt +++ b/pitfall/fontkit/subset.rkt @@ -113,17 +113,19 @@ https://github.com/mbutterick/fontkit/blob/master/src/subset/TTFSubset.js (define gid (list-ref (· this glyphs) idx)) (send this _addGlyph gid)) - (define maxp (cloneDeep (dump (· this font maxp)))) + (define maxp (cloneDeep (· this font maxp to-hash))) (dict-set! maxp 'numGlyphs (length (· this glyf))) + ;; populate the new loca table (dict-update! (· this loca) 'offsets (λ (vals) (append vals (list (· this offset))))) (loca-pre-encode (· this loca)) - (define head (cloneDeep (dump (· this font head)))) + (define head (cloneDeep (· this font head to-hash))) (dict-set! head 'indexToLocFormat (· this loca version)) - (define hhea (cloneDeep (dump (· this font hhea)))) + (define hhea (cloneDeep (· this font hhea to-hash))) (dict-set! hhea 'numberOfMetrics (length (· this hmtx metrics))) + (send Directory encode port (mhash 'tables diff --git a/pitfall/pitfall/alltest.rkt b/pitfall/pitfall/alltest.rkt index da71d3b3..d9a44839 100644 --- a/pitfall/pitfall/alltest.rkt +++ b/pitfall/pitfall/alltest.rkt @@ -14,6 +14,6 @@ pitfall/test/test11 pitfall/test/test12 ; ttf subset pitfall/test/test13 ; subset with composites - ;pitfall/test/test14 ; Fira ttf + pitfall/test/test14 ; Fira ttf with GPOS pitfall/page-test (submod pitfall/zlib test))) \ No newline at end of file diff --git a/pitfall/pitfall/test/test14.rkt b/pitfall/pitfall/test/test14.rkt index d25d0e99..f0afa049 100644 --- a/pitfall/pitfall/test/test14.rkt +++ b/pitfall/pitfall/test/test14.rkt @@ -1,5 +1,6 @@ #lang pitfall/pdftest +;; subset font with GPOS table (define-runtime-path ttf-path "assets/fira.ttf") (define (proc doc) @@ -14,7 +15,7 @@ ;; test against non-subsetted font version (define-runtime-path this "test14rkt.pdf") -(make-doc this #f proc #:pdfkit #t) +(make-doc this #f proc ) (define-runtime-path that "test14crkt.pdf") (make-doc that #t proc #:pdfkit #f) diff --git a/pitfall/pitfall/test/test14rkt.pdf b/pitfall/pitfall/test/test14rkt.pdf index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..a2e57e9ff54b90fdec078efe227257a47151b71a 100644 GIT binary patch literal 6287 zcmbVRU2GfKb-pwFkvx(t$&#q78GA1^qAZIu;-5%SwpL5?PnKn8X-T$8Yt`k59Ld~R zq?V!*d$-swP_$SGXn`VVQWPyv1Vsbn>C&4Nn;=-^r9d8nJ_P7v`_zY^NPs?UP@sk7 zerNb2O18U2#-2Inp8MT%&pG$pJDekLHkHwXvth;i0+$lu0bbpHUs+sK{8^)BR_Z(m z(VF64GY_hVwW4{z=bD0KwNgj_0S`CZcg#}RNK~Kj%>V?^V2IBzgtip_#?yV1L)osW zEG;Q!r9}EkM|++O6mgm`6XH=z7jXV;ty)|+>wMD>3%P&8d{XEBl|86Qv}m$LSGKwo zlQC_@x6R6K{Sgm_A_O?7*GywiA$I~?Cj$F;aZmZ+6|%%eOBm$A0KAFDW}~49-`KOP zByLC9Tnq#P=naH$hjGv0j^I8eTjGH&zHv)QZzy*aa=&FqD-iQt_9kIqy3_bu7mz+zh<`d4|&o43GOxahwO9q?^0ZfGdug} z`1|sk_KVEMdYG35*+5*GnHuVK*kxu9_$1G;$1&^~mR)0`&K}(A#8e~_jYj6C)QKLe zH5UzEpkC?$FTZ*GuJrfE-;w6aVLddcD1(uyi|VEEUPs@+^$F+b=-?pkDO& zI)y?P0oxoXSPASRD?-2-a-iIIUrB`mI>6R~k=Z`-AF5Rg|k9K$IhA&$$zLfgq->?DZjZgGR z5|eHzcAJge#DvnO38PW{ncppTNZ`s&s|8wtUZl3 z&5lbjjSF@!m(Fv(`Z+s)cU3soALhiITTJH*JN)QgPRL&4C%vqf6^rV&+v5=|FIZAd zJ;RL2LP8gkCU{{-7qZ4nT>LyM>{Ab)O-o8LT}-cS<~*v$eU#%Oo6UJdJn!ZrMqDhP z=Zz-FD2Zu^S}iUD)E^+^&$BrWBaRF%lx(g538y}VxF~Vag1eB<=iNf`<@2gw*_@fr z>%yk-G#7TS0fQXLY)&}Tgm9_}n4cF?K^JySg%yUlo}}*?f@_7wiKd!R5n?rA2zh%) zNJY#q95cG;(Ks2|mn?p6XWM|l%y=PBkV48bvR8Z7)5ntO#EhpC>~q@b;44ink`E>% z;cBEX7lTkUWQBwy0!5fD&L<1} zsKCW}1Wgx1+UiEGVK1fflVZSBpXg#(TfLiGU2h8A9>_;5`30@P29x)4jlsdBkc@;F z^ih%`brX$#dJNzpBo|h~=FR3Bl(`62;t0!2)6RHQ3~Tf5W0UL~ss0eXVu%%}>5ZHiR1-Wc`jC{0ihN7(0;d1*(2&H=vqa*k z(753Ai9?@z0%013ZzDckjA;#ts0(o>I<7TrM8Bpr>_p$t8V;ftwT6?ZTWjBZ-%h zZLi!)su5G^82djFNF`kaI?E%ugny>tkjBzE97D7S!S2Ys+#S+*#IiRGoRoffN8_M) zrFkT0t{>4+%u-8gtPzsN;L#lXhrzELQb1xGF=3y@<3nf+9 zl12%~keoE!;0t-|-Lqp1n1q8_%@{GaiWxHS3&ffQ`d%>!457o)jspO(cOao~w4bpA z8VwBgT1McBHw~R~Cvzbqu2Bp)W_L`rVxTS}G}kS$=*0%-JfkktWVBj~R>;VKRz%rG zZk8|N-AERM62@s8L+w}+m>+|WeK*X}u`G@*$F-w|?%lH~~7@}-Hf zEVE)3^CzuvQ3AH3OUb2TSIlCQG;K`b(7+kq$<(&LU!97}uS$&HC;KRFbiORAF}J5{ zy*>GsjcE!-JE$4*-$Rin6I*_CTwaFDW6jNpw>|dZ$gG&dUcC7l`3lZlX>>$HfVriK zd5~3#S{iZX8NAloak{NhI*L_<^^W!o=M0!{fRTuKM|&n&k}McYa+fe^bgdDFn03Ms zvq2bQ?h)n&nEQkw<^f@d$q|N_JYkYx9ukI_O~MfKE@6n-B1{I%9}tF^_XtBwfiT1v zgh_zeCJZq}!Vps;3^ArAu64q^Lk+P6@vgon8n3&nw4rEXk5GzAxw#L4NDS@2pRSE_qWzJ*~cn>>*3B6h1MTe4eovx;64= z_(Z(;;>%_Wh!f0jV@`Y!v2%b8CB9(s z&Ob|LW2wfZ^yyvvsQxt9u$5AcDQf++_Y)@Bt8jH0HU8Epo9u#Zk{d%>g_=%?x zI=;Q3{;{!(3Yy|ysT+^W#T%8~$0pf8qY_r}OrM{Nay=Xg@L)KKM_?h0A{zB)%8$(u zr=reUSHUYt<*ataD`6a%1bvQhho z^bM5hOw^a&sg=xHxw6ZrS4set>rb!J zuODvLt;!$fB$KEN7-~9l5*|(qg5qMcMo6%3&!|S%_N-OE3da_@%2$5qUa6GfZo68z zQ?8V1tx6@|hBp-jg~(F5SZ}o~S#i(U$MT&G2Insa0J4)1+)J)sRUkPPw526pGIyZv zjjCG%k4Kn>5RphikX#lX_y4lb)&dZxQIXnUs{ z&1q0%iCY!Pz!Ej*Vit++G)b{Zf))t{mbPebw3UFhBGU1ocvz#-uN5}SFS55>F*}jn zukMoq>wbBcQ4zPjZX4Bml`{FjgRMgHSLJBB0yt%yzZ1cmUFk#tM5Z>kRms4%K-L`a zO=};lb?VJ$aw*hh5|yG4+GXu#<|Pem$Lel(@^uYZEtfC>mBvYbvU-Tk5^N`}rLAk= zlNy#5`!=M|LN+fRjYPr`ltWsw$O4km>f)7-EEYxWnywQWD$CgJXJo-3Hq9AXAPDPD z%OdkZtix$pARI&C{fumG{w3U83}?_8TqF=dt@`xXNNB!m-g?cz301THc3_<^RNJP% k98{}yP745jz5F3EA=KQ%My+l|E3yz>P`uvsI~nDF0iEG~#Q*>R literal 0 HcmV?d00001 diff --git a/pitfall/sugar/class.rkt b/pitfall/sugar/class.rkt index e70716a2..2ae7195a 100644 --- a/pitfall/sugar/class.rkt +++ b/pitfall/sugar/class.rkt @@ -33,9 +33,6 @@ #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))]) (MAKER ID-CLASS . ARGS))))) -(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) - #'(define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) - (define-macro (define-class-predicates ID) (with-pattern ([+ID (prefix-id "+" #'ID)] @@ -43,11 +40,20 @@ #'(begin (define (ID? x) (is-a? x ID)) (define (+ID . args) (apply make-object ID args))))) -(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) +(define-macro (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) #'(begin - (define ID (class SUPERCLASS (init-field . INIT-ARGS) . BODY)) + (define ID (class* SUPERCLASS INTERFACES (init-field . INIT-ARGS) . BODY)) (define-class-predicates ID))) +(define-macro (define-subclass/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) + #'(define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) (super-new) . BODY)) + +(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) + #'(define-subclass*/interfaces SUPERCLASS () (ID . INIT-ARGS) . BODY)) + +(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) + #'(define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) + (define-macro (push-field! FIELD O EXPR) #'(set-field! FIELD O (cons EXPR (get-field FIELD O)))) diff --git a/pitfall/sugar/js.rkt b/pitfall/sugar/js.rkt index 93c3b7fb..f7c92862 100644 --- a/pitfall/sugar/js.rkt +++ b/pitfall/sugar/js.rkt @@ -46,11 +46,12 @@ (for/fold ([x x]) ([ref (in-list refs)]) (cond + ;; give `send` precedence (presence of method => wants runtime resolution of value) + [(and (object? x) + (memq ref (interface->method-names (object-interface x)))) (dynamic-send x ref)] ;; dict first, to catch objects that implement gen:dict [(dict? x) (dict-ref x ref #f)] - ;; give `send` precedence (presence of method => wants runtime resolution of value) [(object? x) (cond - [(memq ref (interface->method-names (object-interface x))) (dynamic-send x ref)] [(memq ref (field-names x)) (dynamic-get-field ref x)] [else #f])] [else (raise-argument-error '· "object or dict" x)]))) '·)) diff --git a/pitfall/xenomorph/private/base.rkt b/pitfall/xenomorph/private/base.rkt index eae921b3..59811aee 100644 --- a/pitfall/xenomorph/private/base.rkt +++ b/pitfall/xenomorph/private/base.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require racket/class sugar/class racket/generic racket/private/generic-methods "generic.rkt" racket/port) +(require racket/class sugar/class racket/generic racket/private/generic-methods "generic.rkt" racket/port racket/dict racket/function) (require sugar/debug) (provide (all-defined-out)) (define-generics posable @@ -41,24 +41,28 @@ (generic-method-table gen:sizable (define (size o [val #f] [parent #f]) (send o size val parent)))]))) - -(define-generics dumpable - (dump dumpable) - #:defaults - ([input-port? (define (dump p) (port->bytes p))] - [output-port? (define (dump p) (get-output-bytes p))])) - -(define dumpable<%> - (interface* () - ([(generic-property gen:dumpable) - (generic-method-table gen:dumpable - (define (dump o) (send o dump)))]))) +(define (dump x) + (let loop ([x x]) + (cond + [(input-port? x) (port->bytes x)] + [(output-port? x) (get-output-bytes x)] + [(dict? x) (for/list ([(k v) (in-dict x)]) + (cons (loop k) (loop v)))] + [(list? x) (map loop x)] + [(and (object? x) (memq 'dump (interface->method-names (object-interface x)))) (send x dump)] + [else x]))) + +#;(define dumpable<%> + (interface* () + ([(generic-property gen:dumpable) + (generic-method-table gen:dumpable + (define (dump o) (send o dump)))]))) (define (symbol-append . syms) (string->symbol (apply string-append (map symbol->string syms)))) (define xenomorph-base% - (class* object% (codable<%> sizable<%> dumpable<%>) + (class* object% (codable<%> sizable<%>) (super-new) (field [_hash (make-hash)] [_list null]) diff --git a/pitfall/xenomorph/private/string.rkt b/pitfall/xenomorph/private/string.rkt index 49c1eeb4..8ad56856 100644 --- a/pitfall/xenomorph/private/string.rkt +++ b/pitfall/xenomorph/private/string.rkt @@ -8,27 +8,27 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee |# (define (read-encoded-string port len [encoding 'ascii]) - (define proc (caseq encoding - [(utf16le) (error 'bah)] - [(ucs2) (error 'bleh)] - [(utf8) bytes->string/utf-8] - [(ascii) bytes->string/latin-1] - [else identity])) - (proc (read-bytes len port))) + (define proc (caseq encoding + [(utf16le) (error 'bah)] + [(ucs2) (error 'bleh)] + [(utf8) bytes->string/utf-8] + [(ascii) bytes->string/latin-1] + [else identity])) + (proc (read-bytes len port))) (define (write-encoded-string port string [encoding 'ascii]) - ;; todo: handle encodings correctly. - ;; right now just utf8 and ascii are correct - (caseq encoding - [(utf16le ucs2 utf8 ascii) (write-bytes (string->bytes/utf-8 string) port) - (when (eq? encoding 'utf16le) - (error 'swap-bytes-unimplemented))] - [else (error 'unsupported-string-encoding)])) + ;; todo: handle encodings correctly. + ;; right now just utf8 and ascii are correct + (define proc (caseq encoding + [(ucs2 utf8 ascii) string->bytes/utf-8] + [(utf16le) (error 'swap-bytes-unimplemented)] + [else (error 'unsupported-string-encoding)])) + (write-bytes (proc string) port)) (define (count-nonzero-chars port) - ;; helper function for String - ;; counts nonzero chars from current position - (length (car (regexp-match-peek "[^\u0]*" port)))) + ;; helper function for String + ;; counts nonzero chars from current position + (length (car (regexp-match-peek "[^\u0]*" port)))) (define (byte-length val encoding) (define encoder @@ -78,8 +78,22 @@ https://github.com/mbutterick/restructure/blob/master/src/String.coffee (define-values (String? +String) (values StringT? +StringT)) +(define-subclass StringT (Symbol) + (define/override (post-decode string-val . _) + (string->symbol string-val)) + + (define/override (pre-encode sym-val . _) + (unless (or (string? sym-val) (symbol? sym-val)) + (raise-argument-error 'Symbol "symbol or string" sym-val)) + (if (symbol? sym-val) sym-val (string->symbol sym-val)))) + + (test-module - (define S (+String uint8 'utf8)) - (check-equal? (send S decode #"\2BCDEF") "BC") - (check-equal? (send S encode #f "Mike") #"\4Mike") - (check-equal? (send (+String) size "foobar") 7)) ; null terminated when no len \ No newline at end of file + (define S (+String uint8 'utf8)) + (check-equal? (decode S #"\2BCDEF") "BC") + (check-equal? (encode S "Mike" #f) #"\4Mike") + (check-equal? (size (+String) "foobar") 7) ; null terminated when no len + (check-equal? (decode (+Symbol 4) #"Mike") 'Mike) + (check-equal? (encode (+Symbol 4) 'Mike #f) #"Mike") + (check-equal? (encode (+Symbol 4) "Mike" #f) #"Mike") + (check-exn exn:fail:contract? (λ () (encode (+Symbol 4) 42 #f)))) \ No newline at end of file diff --git a/pitfall/xenomorph/private/struct.rkt b/pitfall/xenomorph/private/struct.rkt index c4d08146..bc8d0402 100644 --- a/pitfall/xenomorph/private/struct.rkt +++ b/pitfall/xenomorph/private/struct.rkt @@ -26,7 +26,11 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (if (LazyThunk? res) ((LazyThunk-proc res)) res)) (define (dict-remove! d k) (d:dict-remove! (choose-dict d k) k)) ;; public keys only - (define (dict-keys d) (d:dict-keys (get-field _kv d))))] + (define (dict-keys d) (d:dict-keys (get-field _kv d))) + (define (dict-iterate-first d) (and (pair? (dict-keys d)) 0)) + (define (dict-iterate-next d i) (and (< (add1 i) (length (dict-keys d))) (add1 i))) + (define (dict-iterate-key d i) (list-ref (dict-keys d) i)) + (define (dict-iterate-value d i) (dict-ref d (dict-iterate-key d i))))] [(generic-property gen:custom-write) (generic-method-table gen:custom-write (define (write-proc o port mode) @@ -34,23 +38,29 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee [(#t) write] [(#f) display] [else (λ (p port) (print p port mode))])) - (proc (get-field _kv o) port)))]))) + (proc (dump o) port)))]))) -(define StructDictRes (class* RestructureBase (dictable<%>) - (super-make-object) - (field [_kv (mhasheq)] - [_pvt (mhasheq)]) +(define-subclass*/interfaces xenomorph-base% (dictable<%>) + (StructDictRes) + (super-make-object) + (field [_kv (mhasheq)] + [_pvt (mhasheq)]) - (define/override (dump) _kv))) + (define/override (dump) + ;; convert to immutable for display & debug + (for/hasheq ([(k v) (in-hash _kv)]) + (values k v))) + + (define/public (to-hash) _kv)) (define-subclass xenomorph-base% (Struct [fields (dictify)]) (field [[_post-decode post-decode] (λ (val port ctx) val)] [[_pre-encode pre-encode] (λ (val port) val)]) ; store as field so it can be mutated from outside - (define/overment (post-decode res stream [ctx #f]) - (let* ([res (_post-decode res stream ctx)] - [res (inner res post-decode res stream ctx)]) + (define/overment (post-decode res . args) + (let* ([res (apply _post-decode res args)] + [res (inner res post-decode res . args)]) (unless (dict? res) (raise-result-error 'Struct:post-decode "dict" res)) res)) @@ -65,30 +75,30 @@ https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee (define/augride (decode stream [parent #f] [len 0]) ;; _setup and _parse-fields are separate to cooperate with VersionedStruct - (let* ([res (_setup stream parent len)] - [res (_parse-fields stream res fields)]) - res)) + (let* ([sdr (_setup stream parent len)] ; returns StructDictRes + [sdr (_parse-fields stream sdr fields)]) + sdr)) (define/public-final (_setup port parent len) - (define res (make-object StructDictRes)) ; not mere hash - (dict-set*! res 'parent parent + (define sdr (make-object StructDictRes)) ; not mere hash + (dict-set*! sdr 'parent parent '_startOffset (pos port) '_currentOffset 0 '_length len) - res) + sdr) - (define/public-final (_parse-fields port res fields) + (define/public-final (_parse-fields port sdr fields) (unless (assocs? fields) (raise-argument-error '_parse-fields "assocs" fields)) - (for/fold ([res res]) + (for/fold ([sdr sdr]) ([(key type) (in-dict fields)]) (define val (if (procedure? type) - (type res) - (send type decode port res))) + (type sdr) + (send type decode port sdr))) (unless (void? val) - (ref-set! res key val)) - (ref-set! res '_currentOffset (- (pos port) (· res _startOffset))) - res)) + (dict-set! sdr key val)) + (dict-set! sdr '_currentOffset (- (pos port) (· sdr _startOffset))) + sdr)) (define/augride (size [val #f] [parent #f] [include-pointers #t]) diff --git a/pitfall/xenomorph/test/struct-test.rkt b/pitfall/xenomorph/test/struct-test.rkt index 949962ec..72d5560d 100644 --- a/pitfall/xenomorph/test/struct-test.rkt +++ b/pitfall/xenomorph/test/struct-test.rkt @@ -14,7 +14,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (check-equal? (dump (decode (+Struct (dictify 'name (+StringT uint8) 'age uint8)))) - (mhasheq 'name "roxyb" 'age 21))) + (hasheq 'name "roxyb" 'age 21))) @@ -25,7 +25,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee 'age uint8))) (set-field! post-decode struct (λ (o . _) (ref-set! o 'canDrink (>= (· o age) 21)) o)) (check-equal? (dump (decode struct)) - (mhasheq 'name "roxyb" 'age 32 'canDrink #t))) + (hasheq 'name "roxyb" 'age 32 'canDrink #t))) @@ -36,7 +36,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee 'age uint8 'canDrink (λ (o) (>= (ref o 'age) 21))))) (check-equal? (dump (decode struct)) - (mhasheq 'name "roxyb" 'age 32 'canDrink #t))) + (hasheq 'name "roxyb" 'age 32 'canDrink #t))) @@ -95,7 +95,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) (check-equal? (dump (decode (+Struct (dictify 'name (+StringT uint8) 'age uint8)))) - (mhasheq 'name "roxyb" 'age 21))) + (hasheq 'name "roxyb" 'age 21))) ; it 'should support preEncode hook', (done) -> @@ -115,6 +115,6 @@ https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee (define struct (+Struct (dictify 'name (+StringT uint8) 'age uint8 'ptr (+Pointer uint8 (+StringT uint8))))) - (encode struct (mhasheq 'name "roxyb" 'age 21 'ptr "hello")) + (encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello")) (check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello")) diff --git a/pitfall/xenomorph/test/versioned-struct-test.rkt b/pitfall/xenomorph/test/versioned-struct-test.rkt index d25ba6fd..4359a8a8 100644 --- a/pitfall/xenomorph/test/versioned-struct-test.rkt +++ b/pitfall/xenomorph/test/versioned-struct-test.rkt @@ -18,15 +18,15 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) - (check-equal? (dump (decode struct)) (mhasheq 'name "roxyb" - 'age 21 - 'version 0))) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb" + 'age 21 + 'version 0))) (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 🤘\x15\x00"))]) - (check-equal? (dump (decode struct)) (mhasheq 'name "roxyb 🤘" - 'age 21 - 'version 1 - 'gender 0)))) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘" + 'age 21 + 'version 1 + 'gender 0)))) ; it 'should throw for unknown version', -> @@ -55,17 +55,17 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")]) - (check-equal? (dump (decode struct)) (mhasheq 'name "roxyb" - 'age 21 - 'alive 1 - 'version 0))) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb" + 'age 21 + 'alive 1 + 'version 0))) (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 🤘\x00"))]) - (check-equal? (dump (decode struct)) (mhasheq 'name "roxyb 🤘" - 'age 21 - 'version 1 - 'alive 1 - 'gender 0)))) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘" + 'age 21 + 'version 1 + 'alive 1 + 'gender 0)))) ; it 'should support parent version key', -> @@ -79,15 +79,15 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'gender uint8)))]) (parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")]) - (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (mhasheq 'name "roxyb" - 'age 21 - 'version 0))) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb" + 'age 21 + 'version 0))) (parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))]) - (check-equal? (dump (decode struct #:parent (mhash 'version 1))) (mhasheq 'name "roxyb 🤘" - 'age 21 - 'version 1 - 'gender 0)))) + (check-equal? (dump (decode struct #:parent (mhash 'version 1))) (hasheq 'name "roxyb 🤘" + 'age 21 + 'version 1 + 'gender 0)))) @@ -105,18 +105,18 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'isDessert uint8)))))]) (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) - (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (mhasheq 'name "roxyb" - 'age 21 - 'version 0))) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb" + 'age 21 + 'version 0))) (parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")]) - (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (mhasheq 'name "pasta" - 'version 0))) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "pasta" + 'version 0))) (parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")]) - (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (mhasheq 'name "ice cream" - 'isDessert 1 - 'version 1)))) + (check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "ice cream" + 'isDessert 1 + 'version 1)))) ; @@ -131,10 +131,10 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe 'gender uint8)))]) (set-field! post-decode struct (λ (o stream ctx) (ref-set! o 'processed "true") o)) (parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")]) - (check-equal? (dump (decode struct)) (mhasheq 'name "roxyb" - 'processed "true" - 'age 21 - 'version 0)))) + (check-equal? (dump (decode struct)) (hasheq 'name "roxyb" + 'processed "true" + 'age 21 + 'version 0)))) ; @@ -331,9 +331,9 @@ https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffe [stream (open-output-bytes)]) (set-field! pre-encode struct (λ (val port) (ref-set! val 'version (if (ref val 'gender) 1 0)) val)) (encode struct (mhasheq 'name "roxyb" - 'age 21 - 'version 0) stream) + 'age 21 + 'version 0) stream) (encode struct (mhasheq 'name "roxyb 🤘" - 'age 21 - 'gender 0) stream) + 'age 21 + 'gender 0) stream) (check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))