From a5ca75f7b332a4fc74e8787a4eaeab4b1d250f29 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 4 Feb 2009 19:58:25 +0000 Subject: [PATCH] PR 10040 svn: r13423 --- collects/redex/private/bitmap-test.ss | 14 +++ .../redex/private/bmps/metafunction-T.png | Bin 0 -> 2966 bytes .../redex/private/bmps/metafunction-TL.png | Bin 0 -> 3776 bytes collects/redex/private/core-layout-test.ss | 6 +- collects/redex/private/core-layout.ss | 110 ++++++++++++------ 5 files changed, 91 insertions(+), 39 deletions(-) create mode 100644 collects/redex/private/bmps/metafunction-T.png create mode 100644 collects/redex/private/bmps/metafunction-TL.png diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss index fdff95ce89..ab854394a0 100644 --- a/collects/redex/private/bitmap-test.ss +++ b/collects/redex/private/bitmap-test.ss @@ -62,5 +62,19 @@ (λ (z) (z z))))) "lw.png") +(define-metafunction lang + [(TL 1) (a + ,(term-let ((x 1)) + (term x)) + below-only)] + [(TL 2) (a + ,(term-let ((x 1)) + (term x)) beside + below)]) + +;; this tests that term-let is sucked away properly +;; when the metafunction is rendered +(test (render-metafunction TL) "metafunction-TL.png") + (printf "bitmap-test.ss: ") (done) diff --git a/collects/redex/private/bmps/metafunction-T.png b/collects/redex/private/bmps/metafunction-T.png new file mode 100644 index 0000000000000000000000000000000000000000..59cf44983d6a60870a27b8b809f52602885a1acc GIT binary patch literal 2966 zcmV;H3u*L;P)Z<<&^oqNFa<}^BD83g zN9ibvEoHPYG7}}kh*Sr0X+Z>w7EY^}GOBxy)rfU|6eOh%e9lE-@s;jF30CjbBGZCFpVqs=x2IUeOC=U&UnVFf= z(e!;eIy&0f+08^;MhxOr2Vi2l=$As7OjcZ6?C9uNUtfRq>QxU9kJi>!t(ujUm0n(6 zhYufCj$yi}tgN)tVEOXpdc`@b&~F!KVPUau-MZr9;?&gC(9qDjy1I!peSCb9l9FO$ zW0_2*kB`s$@4pYz#XIl3^V@H~sR>ailwNVpDyFg#_xJbD$;k-}4AiZ*YSpUY;b9Jk z>|I2w(1adDYKRI`?;q);FbG&VL)s%CC(zH;Ttva&KVnY?l1MwrH{s;a`n z!_|aTDz&h%Q13uz2YRRQ_U+sL{{CrcX%8PhL?V%{uC5&&9c(r`EG!I(M5-zK`T3QW zmhRlS)5^*UrhO`vnv;{GCe$%qCX?wE|Lcby+nMt6a&K?%;o;%Mix&q62gk?9LqF@V zSggp%NH&|TImOe{b8v7lARqv~7d#&SCk;G2JhUqFc)ZlqQ~*G3Zf<*fJA5y%6ECj9 zh=_=YhzK33{{H@@rKJP{0RWJmo-UKgpj}3EbToxRnLmHN=9I^eALr%e&2-E!u(Pvc zGMP*!({L{S_~^O{Z{51p*w`qS%b|fpB7yP;06-uR%3We_Z|~sXpz4Jp7K@vkn;$%Q zuwcOg2L}g8*w@#`;c!}7TA)2nOG}GkRy6A{Qz#T#KX~-$kx(cE03eY_sZ!a^@jFh2*2I@-u7oRd5ikTf6HOY^|+BD5C-4-?8`c7gC|UR`d4SO$HvB9 zvfqB8aNE(uzg;Q*x$NJOX~|8U9aFQT2CK5-_m(C&@)ucYYio0Lb^Z9`k3}NU7hilq zB9Sg#xVv)O@xfzYWDi9}IRQDici!C*j7BU~;wA|hh_`t>m}F+3hmC={lor1<*! z=I7_z+uK)ERH!NF2>L0nXJBaPEhqAnmn{^Did0D!x9 z?-msm9XxoDLZKuiB)GY`#m2^-Idg_UAOr;kWoBkFnM@*)c<o(TwQJYf+S>N--=CP6n39sRcI{dwlUZ3=xo6LwyQ!G~0B`q2ao?qiM@KN0 zXjKcE@^KFp;o;$4US1-R2#rQtTU!?t6nJ`ivf1o}gak-|PN$PdBoc`ffV z$l-7@GBN-FI2?|{;UEwQcXxLz77JAqtE#Hh6m%@_*Zb9}QE|{1X<@PLgO3t(b1olA zv%+9{1bxXD&Yq0h2LL$s)44Ytovt1~2>{^odn415FD4zsSfUR{L=TC@$D`tqdcKXQ z>K6bIb0TH;#*n41Zvy~${etZ&f4zJp&D`8PGA%hVY=^tcn*e~a>boE9-y<%)rTY3$ zH@`RS??0~c(zRpIS~JIBFj{Nll(`PIO^x)0i`9&%$;YjhMx)Vaw9A(-!E++LW8X0Ns>g2SyaoXD;2@Z?> z{Ymp%^T-%WODKN;fR*ohdA+?*)yUxRP-NQC?7tkCXFK`pSZX!%iE86-I68Ikp3#AN z3f1K5JCv}nu)Msyva+(|^h!i>AI*b#}Mk&#Jf=|I)5nHjJ`V_Y2ODgWX&ggDQ2L|Rx343E1*3Wmll1Z#;t z$cTWGKcG=FSJuW$OG{O2+IsxZ;QJQuh=?wq{lXN|+xH9ud! zTrU6V8hiPYccDY#oH_kN6aI_9@r$uU+u#Y-I2?W9V(8D~EmsS3b4wJ8V((CN^ZMA> zm_#Z)U39TW(5Gr-P&ACk!YXS+HFFdS_3+_CWg`9j{H|ZWj=^A5i`y+-PZz(rK+}Sn zTs?&(5^2kpEnBv10RS)<3$&-?j5-yipSXekRGLoL2URYR2 zrBZkA-o0tlroO(ubLY+p1cFniPC?}eH3c1O+rB#Jmm6i!n9J`?zm$KD&1z_S0szRr z#=dd?9{Wxu0N|Tlds6bxGma)6$vd-r_s-8lw%QVj(5z2CTE8#zMAqeBj{bNyGA&t| zY2B#$1ps91`SR=h^IMa@`u?9qUuJ)|H{;vk5itPZ+nCRqpLT{GJ{b0O62Z!9^NMkG z>`#v$p>5mL+4D??qw<<6tu=F?tv24#(``qzwznp!8PSw$sZ>a%QspZYs^f`}N~J=f zkVH~<21{Z5?|~nD9-GfRLW1##_NX>I`RicLCLYmnCi!m0+xACsyUZrGnZte^`lA8 zBOJdr1fmUr2;Tw`ha*n>9ic?6W-b|WmoJ~s_wn(msi|4LdNr9$4hjn5^Z7FrrZHi} z+Zm};di(b64I4JBTemJgKE9%&0%l3%HN#L{zVJ2G(6`I?(4j+7QBk{g?b^F{Z*6U@ zUdwqsFjSW>d`&g37^KU0B275x)#Ymf001U>VAT3(-{0R44aUaCMn^}L$}ASE zwzgJv`b3%`At4zV8L9&l)5IWMzCfe42~1tS2E!m-zFIML`5K7-0eQ5ceLM0N-v9sr M07*qoM6N<$f;kGjaR2}S literal 0 HcmV?d00001 diff --git a/collects/redex/private/bmps/metafunction-TL.png b/collects/redex/private/bmps/metafunction-TL.png new file mode 100644 index 0000000000000000000000000000000000000000..4863d12cdc674f1808041521604680fedad5adee GIT binary patch literal 3776 zcmXAs2{@E(7snrzh7u{e#!_}6MZH;K?2(4bQ1%#83R$v_;X{QOOZJha#u73U28lvr zl%3bE>}GuS>|uQO`+jp>vs`mO&wZBre}3mY(MWS6E>2-i2!gmwjP)(ScNBQvgRz27 zp>Ebh2s-(~L|^w#0AYy`tU^GE(eU*(M=X{;QJ>hM^@P)&&)*ozRk|tlQL;t8|CLM8 zWsZ?{L5tgc#)k}9^gUraITH=}9+TUKr}_SCF2Z3bb!vfE?mw>nb`*a1u07iPp0C5V zx>Q%OpIr`g0$tOs>(V&3Gw{tiVI1}3*)uE2#4y*Qk`mMNywUpk#l^Mz40#=xfPjF> z`QFUVq=? zx2UwVeRz0xZJH)KIxt{`MCuSNm2GRncpb2t{eLtr@W=Xid-L=24~)O=mDp7d3=BNN z%F>2_J#cmwJi%`Jysj?T#wNp;^`fTc{zM}iq+?|C!WYXQo06St_FAtuucdxv37O$gyQaLo~jF+U$27gt500QXEyOl+P` zPz5-}X0PzWCaJLk3JMAqsZ?hnK|#{+VsUZt(2%v88$BT*p=@dLngyp;W@cu(*<4Z+ z$^lzdP=Gd>?C$RV`ZbJ5l!A056KiT}LiX2aXfzrMi;0O53*FHr(%4C!;|-~)sZvo2 z+8TcT{vv{cxw?2AabV!bj~`=WV{hKPxnJ#Zl%3tf(4Q~bl95+jY(lhjEtWgO2~ut$ zjHtmKhAO26&$OO$aB$$_;>tr7eYN-Cypcyc*xP=apPzcB7gL#a#ZyVHvZ6vnOiUn_ zdY-qqprD|>KD&7`Ju8b1djJ0Yz#)k=yDz3CEh8f$EKDi|F2%;S$!}7f$)ef0J($Pp z!6tbW%GU49fq?-K=i9e$!4@v6Hj;_Cqr{INKY~;2>be#0fRbn8;b+gDJ;Bb_w*0HU zuB2qaAf?vU!^1-f%FWFcmyl=#>25J!1d2Fh9(?>8sEC7uo-{ts`#L=*$AK)2rv?9>F>!FnLCWe!`|bNM4N<5o zQc|;ZD-C)!mo8m8efsq40;H@$y!TZE7oujs=hLT81%-tykc+C&1<9qKbtqF)_rQ+E z#zuNqj_F`!W##3|mu)@ESp?zmf!^NU!9fSy?Hf^=K}ASW?|78_naCU5vk2k~@4Q~U zTI775?SwTq+1l3966o*u>SXh1wWr3lYuea9z9kw}_Fjjd|8Xx`pBD~qm?{h%3!mO& zn_OD@IXYUW^$i-;;nvRSn)IT45)ff;*u;2vfIL~DP`C|7&ld7%dC(mcs&C#m56PIA z@LC)q&&YQl2k^i>$g;%MOk(G$*gtfi#|f+8X!mY0{U!;ZJ?>;zyivQdaU zOHgygnDd16^s8PII`{97-uJ9`MWdf>Ff8Uz`2_`yG&i%2zW!WO!E!kc2rQk=-D%;*p`D zp&%VRO|7lQ%F4>6XQh*cczGogjb+dL=*YSv5eYy8-~lir5vg+R+BFFYr|-AYQd3zW z5Id4WA|dVU?9TJ%bzC0&V5c|x@Zm$>YiALy=!)&dVK#~O&QA4<7j?0*c>MO-TI0z6 z{(9HJ!ND39#}lpp_`!5z#4#ye6C4g_YI-~hQR_QzdGDXs$i~J-^9ycb*CS8Q?bX$< zA3uEf0L(mk^aunB64v!bD=Rx&3;XBti0pk7ioUYaMPIi&G&L|V2oBbWGrXjtqH_U& z60l@@d;0-beq?d6obZMU0)a3zGU`Dylai9UyOE0twY7o%{?(R?g{dNHRk#6xZgv$l zH8t&=@`3_s9vHGVIr%ij>15;dn%T{pWJSvAEU<*G0CE#N@jNXJ1^R)5!+2leEiElA zDcjM@ewd_V)HtQc}Xg!a#~Z2egv_{Hp<)Aqx`xvBAN? z{wu$@AW(+VywO(wzBJ*==gzV9Kg3|Hd0&7omX(>=?ZO6O9zG;jRUL(Pc6X^QEmn8$ zUKBiW?%X*Mk*tjkUw{AYvl`DJh{VnURaI31-C(k`9);^m+T6RRl(UuA>`ZRhnK}-* z4*W&g2Od?RuLXc^xC1YTpzq(mBl3`-s)rYW#I&^PU%q_#{Q2|VUQ3wM&6_td7zXG* z8*)xgPP4PKn1K1k#nR&9zXE@shrYJAx3{#+?X7$e zKM#-PA1Mmp#*#7q-Xq73T@U;n*@3RGR-FHxn0QJ?Mkb_-uHnD@DmuCcaPRNG$ErQW zDCBE$a?v{CjD>~d?=#>KsZ;}5wVbYw4g*8OB;)h$?(UL_J3U5XPRTf1TS9z%XHyev zB##yhwA&9m3*(`COYvtl6crUKtEz-fv@jU5kvtuAEEZd29va$^lEU{ov+EQXB7l}} z-@e_;rJB+H=TDI6Lij~(?O%O;6`x7P#q+!CbmeRAAoA+*&@2Ms^`3uWVIdBbzFXIu zvdwQrMMVq-Ww^Vkyq{5-uB7@gJJxFfyd)%G#YSOHwB($_UMs(%8i5H zZOX*sfYaSD4v9Nhyrq)YVMtYnIGBCnHn&f~jwsh}^s@VTs!@nvxC1Q2XZuS~sI}z4 zy`^f;u^QdNJ`036j}ENdzW$S27o0cRcV~6-*DrgR6UYaMi%4{}wB)@}dOef}Q9~jn zWM{{1BOCdKRd6`~e-&coegU!24?T-~sOl{GVGM6s(f%&4dbNQ$L zcv(@=*OSHjSQoeEfpS(>R#GJ(Pj&USVU;4+o!z}wT|2v<8Y`dA1!GgbaJRH9^b8If zNhXr|AKD;y_Z%OS;Opz_pls0Ly%#x3SW`&g!Kygz@+7yJ}3 zBr70~6PrbB9_ZEXph6C<-CdeuUh3!bHS+;hG5;)-`>DsTm3KcVOXN_PqSLpB-EuA{ z<5udowRdNd!CLsrfmfD^lhdTMrsBTBGI!)+B8Q%y9%#memc^hOf(VLKKpQuZh9G%) z`Oo$BU=RUXAqwo4JA7H5n?t+0^6~LWjl*`8d-b+jBTdtkxK5ln!^cPc_U#>!nCJNy zH(XQazVPVC2rC<#pRX_P>C-E}>i4Gc*Ymf)7GSVhnx0P1%F<9(^Zw|Fg$sJXi@RN0?wSi!3SnF?m) zmXu_@dDDrmpgLa+*8$riu5(`7;F11^FvK&pm^hhM#V1yJ55 z7`}SF)UU~cH}qihpHb{!`DYzZQ%%iP>Ez-5{>}U!;52HyXE`&>)KyhgFJA_|N?&7$ zyc^=-5l?jnmCPA6H8sV1>QwmLI-neTgswObxaQf?NEG7KAZPqw`ONBeMtV9A?1;L$ zx+!N}U0qpe>8rRnGD0b>ZPE*Kc_h|;ac^(WKr%5qJA1>(1m@)Fsf?%jczGqz=a6MG z@*+ELu2aP1wO$_=T_AsFYL^IZJQlw?@F4jB`_3-l%(3{*A(wxDEN>2(;l$dbjGm@N z1Z%1Hjnl;h;8Y2k#=9hv6jQquEC@ucY<^QK%YRT=U2Xc}O3kNFziOVct#3aC4_{1e zMw_FZUG~P7*G$vf8il56c-GuX#9c!r&6qmLkOguEQycdGm4lE5;0Ug6RrVzH=FJ$i z={`2$IDSfrlNRLoIP(klT+`dDln8iML?!qai9Jk6xz5~a{`Ctkv>_LN2zg4n literal 0 HcmV?d00001 diff --git a/collects/redex/private/core-layout-test.ss b/collects/redex/private/core-layout-test.ss index 2b8da2e95f..b1edc2bc72 100644 --- a/collects/redex/private/core-layout-test.ss +++ b/collects/redex/private/core-layout-test.ss @@ -42,7 +42,7 @@ (to-lw ,(term (a b c)))))) - (list (make-line 1 + (list (make-line 0 (list (make-spacer-token 0 2) (make-string-token 2 1 "(" 'roman) (make-string-token 3 1 "a" 'swiss) @@ -64,11 +64,11 @@ ,(term (a b c)))))) - (list (make-line 2 + (list (make-line 1 (list (make-spacer-token 0 5) (make-string-token 5 1 "c" 'swiss) (make-string-token 6 1 ")" 'roman))) - (make-line 1 + (make-line 0 (list (make-spacer-token 0 2) (make-string-token 2 1 "(" 'roman) (make-string-token 3 1 "a" 'swiss) diff --git a/collects/redex/private/core-layout.ss b/collects/redex/private/core-layout.ss index fe501c59b8..fcfad205d7 100644 --- a/collects/redex/private/core-layout.ss +++ b/collects/redex/private/core-layout.ss @@ -118,7 +118,7 @@ - ;; token = string-token | spacer-token | pict-token | align-token + ;; token = string-token | spacer-token | pict-token | align-token | up-token (define-struct token (column span) #:inspector (make-inspector)) @@ -139,6 +139,11 @@ ;; an earlier line) (define-struct align-token (pict) #:inspector (make-inspector)) + ;; lines : number + ;; this token corresponds to a deletion of a bunch of vertical space + ;; things following it start 'lines' lines higher up. + (define-struct (up-token token) (lines) #:inspector (make-inspector)) + ;; n : number (the line number) ;; tokens : (listof token) (define-struct line (n tokens) #:inspector (make-inspector)) @@ -183,9 +188,21 @@ (pair? (cdr content)) (lw? (cadr content)) (equal? 'term-let (lw-e (cadr content)))) + + #; (struct-copy lw an-lw - [e (lw-e (second-to-last content))]) + [e (adjust-spacing (lw-e (second-to-last content)) + (lw-line an-lw) + (lw-line-span an-lw) + (lw-column an-lw) + (lw-column-span an-lw) + 'term-let-rewriter)]) + (struct-copy lw + an-lw + [e (append (list (just-before "" an-lw) 'spring) + (lw-e (second-to-last content)) + (list 'spring (just-after "" an-lw)))]) an-lw)) an-lw)) @@ -224,7 +241,7 @@ (adjust-spacing rewritten line line-span col col-span (lw-e (cadr e)))]) - (map ar/lw adjusted))))] + (map ar/lw adjusted))))] [(and (pair? e) (pair? (cdr e)) (lw? (cadr e)) @@ -329,7 +346,7 @@ 0))]) (cond [(and after-next-lw (null? to-wrap)) - (cons next-lw (loop after-next-lw next-line next-column))] + (list* next-lw (loop after-next-lw next-line next-column))] [(and (not after-next-lw) (null? to-wrap)) '()] [else @@ -343,11 +360,13 @@ (- next-lw-column column) (- next-lw-column init-column))]) (list* (build-lw to-wrap1 line 0 new-lw-col 0) + 'spring (build-lw (blank) line (- next-lw-line line) new-lw-col new-lw-col-span) + 'spring (build-lw to-wrap2 next-lw-line 0 (+ new-lw-col new-lw-col-span) 0) (if after-next-lw (cons next-lw (loop after-next-lw next-line next-column)) @@ -415,26 +434,44 @@ (define initial-line (lw-line lw)) (define current-line (lw-line lw)) (define current-column (lw-column lw)) + + ;; if there are lines that are in the source, + ;; but should not be rendered as blank lines, this counts them + ;; specifically it is the number of such lines that have + ;; already passed. + (define gobbled-lines 0) + (define last-token-spring? #f) (define tokens '()) (define lines '()) - (define (eject line col span atom unquoted?) + (define (eject line line-span col col-span atom unquoted?) (cond [(= current-line line) (void)] [(< current-line line) - ;; make new lines - (for-each - (λ (i) - (set! lines (cons (make-line (+ i current-line) (reverse tokens)) lines)) - (set! tokens '())) - (build-list (max 0 (- line current-line)) values)) - - (set! tokens (cons (make-spacer-token 0 (- col initial-column)) - tokens)) - - (set! current-line line) - (set! current-column col)] + (let ([lines-to-end (- line current-line)]) + + (set! lines (cons (make-line (- current-line gobbled-lines) (reverse tokens)) lines)) + (set! tokens '()) + + (cond [last-token-spring? + ;; gobble up empty lines + ;; we gobble up lines so that we continue on the line we were + ;; on before (which is actually now split into two different elements of the line list) + (set! gobbled-lines (+ gobbled-lines lines-to-end))] + [else + ;; insert a bunch of blank lines + (for-each + (λ (i) + (set! lines (cons (make-line (+ (- current-line gobbled-lines) i) '()) lines))) + (build-list (- lines-to-end 1) add1))]) + + + (set! tokens (cons (make-spacer-token 0 (- col initial-column)) + tokens)) + + (set! current-line line) + (set! current-column col))] [else (error 'eject "lines going backwards")]) (when (< current-column col) @@ -446,41 +483,42 @@ (set! last-token-spring? #f) (set! tokens (append (reverse - (atom->tokens (- col initial-column) span atom all-nts unquoted?)) + (atom->tokens (- col initial-column) col-span atom all-nts unquoted?)) tokens)) - (set! current-column (+ col span))) + (set! current-column (+ col col-span))) - (define (make-blank-space-token unquoted? col span) + (define (make-blank-space-token unquoted? col col-span) (if last-token-spring? - (make-pict-token col span (blank)) - (let ([str (apply string (build-list span (λ (x) #\space)))]) + (make-pict-token col col-span (blank)) + (let ([str (apply string (build-list col-span (λ (x) #\space)))]) (if unquoted? - (make-pict-token col span (pink-background ((current-text) str 'modern (default-font-size)))) - (make-string-token col span str (default-style)))))) + (make-pict-token col col-span (pink-background ((current-text) str 'modern (default-font-size)))) + (make-string-token col col-span str (default-style)))))) - (define (handle-loc-wrapped lw last-line last-column last-span) + (define (handle-loc-wrapped lw) (cond - [(eq? lw 'spring) - (set! last-token-spring? #t)] + [(memq lw '(spring spring-next)) + (set! last-token-spring? lw)] [else (handle-object (lw-e lw) (lw-line lw) + (lw-line-span lw) (lw-column lw) (lw-column-span lw) (lw-unq? lw))])) - (define (handle-object obj line col span unquoted?) + (define (handle-object obj line line-span col col-span unquoted?) (cond - [(symbol? obj) (eject line col span obj unquoted?)] - [(string? obj) (eject line col span obj unquoted?)] - [(pict? obj) (eject line col span obj unquoted?)] - [(not obj) (eject line col span (blank) unquoted?)] + [(symbol? obj) (eject line line-span col col-span obj unquoted?)] + [(string? obj) (eject line line-span col col-span obj unquoted?)] + [(pict? obj) (eject line line-span col col-span obj unquoted?)] + [(not obj) (eject line line-span col col-span (blank) unquoted?)] [else - (for-each (λ (x) (handle-loc-wrapped x line col span)) + (for-each (λ (x) (handle-loc-wrapped x)) obj)])) - (handle-loc-wrapped lw 0 0 0) - (set! lines (cons (make-line current-line (reverse tokens)) + (handle-loc-wrapped lw) + (set! lines (cons (make-line (- current-line gobbled-lines) (reverse tokens)) lines)) ;; handle last line ejection lines) @@ -619,7 +657,7 @@ (let ([max (apply max (map line-n lines))] [min (apply min (map line-n lines))]) (let loop ([i min]) - (let ([lines (apply lbl-superimpose (reverse (hash-ref lines-ht i)))]) + (let ([lines (apply lbl-superimpose (reverse (hash-ref lines-ht i (list (blank)))))]) (cond [(= i max) lines] [else