Merge branch 'master' into new_ui

basis/base64/base64-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel tools.test base64 strings ;
+USING: kernel tools.test base64 strings sequences  ;
 IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
@@ -7,6 +7,7 @@ IN: base64.tests
 [ "a" ] [ "a" >base64 base64> >string ] unit-test
 [ "ab" ] [ "ab" >base64 base64> >string ] unit-test
 [ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
 
 ! From http://en.wikipedia.org/wiki/Base64
 [ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
@@ -15,5 +16,11 @@ IN: base64.tests
     >base64 >string
 ] unit-test
 
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+    "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+    >base64-lines >string
+] unit-test
+
 \ >base64 must-infer
 \ base64> must-infer

basis/base64/base64.factor

@@ -1,16 +1,22 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping
+USING: combinators io io.binary io.encodings.binary
-accessors ;
+io.streams.byte-array io.streams.string kernel math namespaces
+sequences strings ;
 IN: base64
 
 <PRIVATE
 
-: count-end ( seq quot -- n )
+: read1-ignoring ( ignoring -- ch )
-    trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
+    read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+
+: read-ignoring ( ignoring n -- str )
+    [ drop read1-ignoring ] with map harvest
+    [ f ] [ >string ] if-empty ;
 
 : ch>base64 ( ch -- ch )
-    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+    nth ; inline
 
 : base64>ch ( ch -- ch )
     {
@@ -19,32 +25,60 @@ IN: base64
         f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
         22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
         40 41 42 43 44 45 46 47 48 49 50 51
-    } nth ;
+    } nth ; inline
 
-: encode3 ( seq -- seq )
+SYMBOL: column
+
+: write1-lines ( ch -- )
+    write1
+    column get [
+        1+ [ 76 = [ "\r\n" write ] when ]
+        [ 76 mod column set ] bi
+    ] when* ;
+
+: write-lines ( str -- )
+    [ write1-lines ] each ;
+
+: encode3 ( seq -- )
     be> 4 <reversed> [
-        -6 * shift HEX: 3f bitand ch>base64
+        -6 * shift HEX: 3f bitand ch>base64 write1-lines
-    ] with B{ } map-as ;
+    ] with each ; inline
 
-: decode4 ( str -- str )
+: encode-pad ( seq n -- )
-    0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
+    [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
+    [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
 
-: >base64-rem ( str -- str )
+ERROR: malformed-base64 ;
-    [ 3 0 pad-right encode3 ] [ length 1+ ] bi
+
-    head-slice 4 CHAR: = pad-right ;
+: decode4 ( seq -- )
+    [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
+    [ [ CHAR: = = ] count ] bi head-slice*
+    [ write1 ] each ; inline
 
 PRIVATE>
 
-: >base64 ( seq -- base64 )
+: encode-base64 ( -- )
-    #! cut string into two pieces, convert 3 bytes at a time
+    3 read dup length {
-    #! pad string with = when not enough bits
+        { 0 [ drop ] }
-    dup length dup 3 mod - cut
+        { 3 [ encode3 encode-base64 ] }
-    [ 3 <groups> [ encode3 ] map concat ]
+        [ encode-pad encode-base64 ]
-    [ [ "" ] [ >base64-rem ] if-empty ]
+    } case ;
-    bi* append ;
 
-: base64> ( base64 -- seq )
+: encode-base64-lines ( -- )
-    #! input length must be a multiple of 4
+    0 column [ encode-base64 ] with-variable ;
-    [ 4 <groups> [ decode4 ] map concat ]
+
-    [ [ CHAR: = = ] count-end ]
+: decode-base64 ( -- )
-    bi head* ;
+    "\n\r" 4 read-ignoring dup length {
+        { 0 [ drop ] }
+        { 4 [ decode4 decode-base64 ] }
+        [ malformed-base64 ]
+    } case ;
+
+: >base64 ( str -- base64 )
+    binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
+
+: base64> ( base64 -- str )
+    [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
+
+: >base64-lines ( str -- base64 )
+    binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;

basis/io/directories/search/search.factor

@@ -14,7 +14,7 @@ TUPLE: directory-iterator path bfs queue ;
 
 : push-directory ( path iter -- )
     [ qualified-directory ] dip [
-        dup queue>> swap bfs>>
+        [ queue>> ] [ bfs>> ] bi
         [ push-front ] [ push-back ] if
     ] curry each ;
 

basis/io/streams/null/null-docs.factor

@@ -0,0 +1,28 @@
+USING: io help.markup help.syntax quotations ;
+IN: io.streams.null
+
+HELP: null-reader
+{ $class-description "Singleton class of null reader streams." } ;
+
+HELP: null-writer
+{ $class-description "Singleton class of null writer streams." } ;
+
+HELP: with-null-reader
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
+
+HELP: with-null-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
+
+ARTICLE: "io.streams.null" "Null streams"
+"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
+$nl
+"Null readers:"
+{ $subsection null-reader }
+{ $subsection with-null-writer }
+"Null writers:"
+{ $subsection null-writer }
+{ $subsection with-null-reader } ;
+
+ABOUT: "io.streams.null"

basis/io/streams/null/null.factor

@@ -1,22 +1,19 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io io.timeouts io.styles destructors ;
 IN: io.streams.null
-USING: kernel io io.timeouts io.streams.duplex destructors ;
 
-TUPLE: null-stream ;
+SINGLETONS: null-reader null-writer ;
+UNION: null-stream null-reader null-writer ;
 
 M: null-stream dispose drop ;
 M: null-stream set-timeout 2drop ;
 
-TUPLE: null-reader < null-stream ;
-
 M: null-reader stream-readln drop f ;
 M: null-reader stream-read1 drop f ;
 M: null-reader stream-read-until 2drop f f ;
 M: null-reader stream-read 2drop f ;
 
-TUPLE: null-writer < null-stream ;
-
 M: null-writer stream-write1 2drop ;
 M: null-writer stream-write 2drop ;
 M: null-writer stream-nl drop ;
@@ -28,11 +25,7 @@ M: null-writer make-cell-stream nip ;
 M: null-writer stream-write-table 3drop ;
 
 : with-null-reader ( quot -- )
-    T{ null-reader } swap with-input-stream* ; inline
+    null-reader swap with-input-stream* ; inline
 
 : with-null-writer ( quot -- )
-    T{ null-writer } swap with-output-stream* ; inline
+    null-writer swap with-output-stream* ; inline
-
-: with-null-stream ( quot -- )
-    T{ duplex-stream f T{ null-reader } T{ null-writer } }
-    swap with-stream* ; inline

basis/io/styles/styles-tests.factor

@@ -0,0 +1,8 @@
+IN: io.styles.tests
+USING: io.styles tools.test ;
+
+\ stream-format must-infer
+\ stream-write-table must-infer
+\ make-span-stream must-infer
+\ make-block-stream must-infer
+\ make-cell-stream must-infer

basis/smtp/smtp-tests.factor

@@ -15,7 +15,7 @@ IN: smtp.tests
 
 [ { "hello" "." "world" } validate-message ] must-fail
 
-[ "hello\r\nworld\r\n.\r\n" ] [
+[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
     "hello\nworld" [ send-body ] with-string-writer
 ] unit-test
 
@@ -50,7 +50,10 @@ IN: smtp.tests
 
 [
     {
+        { "Content-Transfer-Encoding" "base64" }
+        { "Content-Type" "Text/plain; charset=utf-8" }
         { "From" "Doug <erg@factorcode.org>" }
+        { "MIME-Version" "1.0" }
         { "Subject" "Factor rules" }
         { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
     }

basis/smtp/smtp.factor

@@ -92,9 +92,8 @@ M: message-contains-dot summary ( obj -- string )
     [ message-contains-dot ] when ;
 
 : send-body ( body -- )
-    string-lines
+    utf8 encode
-    validate-message
+    >base64-lines write crlf
-    [ write crlf ] each
     "." command ;
 
 : quit ( -- )
@@ -167,6 +166,13 @@ M: plain-auth send-auth
 
 : auth ( -- ) smtp-auth get send-auth ;
 
+: encode-header ( string -- string' )
+    dup aux>> [
+        "=?utf-8?B?"
+        swap utf8 encode >base64
+        "?=" 3append
+    ] when ;
+
 ERROR: invalid-header-string string ;
 
 : validate-header ( string -- string' )
@@ -175,7 +181,7 @@ ERROR: invalid-header-string string ;
 
 : write-header ( key value -- )
     [ validate-header write ]
-    [ ": " write validate-header write ] bi* crlf ;
+    [ ": " write validate-header encode-header write ] bi* crlf ;
 
 : write-headers ( assoc -- )
     [ write-header ] assoc-each ;
@@ -195,6 +201,13 @@ ERROR: invalid-header-string string ;
     ! This could be much smarter.
     " " split1-last swap or "<" ?head drop ">" ?tail drop ;
 
+: utf8-mime-header ( -- alist )
+    {
+        { "MIME-Version" "1.0" }
+        { "Content-Transfer-Encoding" "base64" }
+        { "Content-Type" "Text/plain; charset=utf-8" }
+    } ;
+
 : email>headers ( email -- hashtable )
     [
         {
@@ -205,7 +218,7 @@ ERROR: invalid-header-string string ;
         } cleave
         now timestamp>rfc822 "Date" set
         message-id "Message-Id" set
-    ] { } make-assoc ;
+    ] { } make-assoc utf8-mime-header append ;
 
 : (send-email) ( headers email -- )
     [

basis/stack-checker/stack-checker-tests.factor

@@ -416,12 +416,7 @@ DEFER: bar
 \ stream-write must-infer
 \ stream-write1 must-infer
 \ stream-nl must-infer
-\ stream-format must-infer
-\ stream-write-table must-infer
 \ stream-flush must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
 
 ! Test stream utilities
 \ lines must-infer

basis/tools/files/files-tests.factor

@@ -1,10 +1,8 @@
-! Copyright (C) 2008 Your name.
+! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test tools.files strings kernel ;
 IN: tools.files.tests
 
-\ directory. must-infer
-
 [ ] [ "" directory. ] unit-test
 
 [ ] [ file-systems. ] unit-test

basis/tools/files/files.factor

@@ -1,24 +1,29 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators io io.files io.files.info
+USING: accessors arrays calendar combinators fry io io.directories
-io.directories kernel math.parser sequences system vocabs.loader
+io.files.info kernel math math.parser prettyprint sequences system
-calendar math fry prettyprint ;
+vocabs.loader sorting.slots calendar.format ;
 IN: tools.files
 
-SYMBOLS: permissions file-name nlinks file-size date ;
-
 <PRIVATE
 
-: ls-time ( timestamp -- string )
+: dir-or-size ( file-info -- str )
+    dup directory? [
+        drop "<DIR>" 20 CHAR: \s pad-right
+    ] [
+        size>> number>string 20 CHAR: \s pad-left
+    ] if ;
+
+: listing-time ( timestamp -- string )
     [ hour>> ] [ minute>> ] bi
     [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
 
-: ls-timestamp ( timestamp -- string )
+: listing-date ( timestamp -- string )
     [ month>> month-abbreviation ]
     [ day>> number>string 2 CHAR: \s pad-left ]
     [
         dup year>> dup now year>> =
-        [ drop ls-time ] [ nip number>string ] if
+        [ drop listing-time ] [ nip number>string ] if
         5 CHAR: \s pad-left
     ] tri 3array " " join ;
 
@@ -28,12 +33,57 @@ SYMBOLS: permissions file-name nlinks file-size date ;
 
 : execute>string ( ? -- string ) "x" "-" ? ; inline
 
-HOOK: (directory.) os ( path -- lines )
-
 PRIVATE>
 
-: directory. ( path -- )
+SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
-    [ (directory.) ] with-directory-files [ print ] each ;
+file-date file-time file-datetime uid gid user group link-target unix-datetime
+directory-or-size ;
+
+TUPLE: listing-tool path specs sort ;
+
+TUPLE: file-listing directory-entry file-info ;
+
+C: <file-listing> file-listing
+
+: <listing-tool> ( path -- listing-tool )
+    listing-tool new
+        swap >>path
+        { file-name } >>specs ;
+
+: list-slow? ( listing-tool -- ? )
+    specs>> { file-name } sequence= not ;
+
+ERROR: unknown-file-spec symbol ;
+
+HOOK: file-spec>string os ( file-listing spec -- string )
+
+M: object file-spec>string ( file-listing spec -- string )
+    {
+        { file-name [ directory-entry>> name>> ] }
+        { directory-or-size [ file-info>> dir-or-size ] }
+        { file-size [ file-info>> size>> number>string ] }
+        { file-date [ file-info>> modified>> listing-date ] }
+        { file-time [ file-info>> modified>> listing-time ] }
+        { file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
+        [ unknown-file-spec ]
+    } case ;
+
+: list-files-fast ( listing-tool -- array )
+    path>> [ [ name>> 1array ] map ] with-directory-entries ; inline
+
+: list-files-slow ( listing-tool -- array )
+    [ path>> ] [ sort>> ] [ specs>> ] tri '[
+            [ dup name>> file-info file-listing boa ] map
+            _ [ sort-by-slots ] when*
+            [ _ [ file-spec>string ] with map ] map
+    ] with-directory-entries ; inline
+
+: list-files ( listing-tool -- array ) 
+    dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline
+
+HOOK: (directory.) os ( path -- lines )
+
+: directory. ( path -- ) (directory.) simple-table. ;
 
 SYMBOLS: device-name mount-point type
 available-space free-space used-space total-space
@@ -43,16 +93,16 @@ percent-used percent-free ;
 
 : file-system-spec ( file-system-info obj -- str )
     {
-        { device-name [ device-name>> [ "" ] unless* ] }
+        { device-name [ device-name>> "" or ] }
-        { mount-point [ mount-point>> [ "" ] unless* ] }
+        { mount-point [ mount-point>> "" or ] }
-        { type [ type>> [ "" ] unless* ] }
+        { type [ type>> "" or ] }
-        { available-space [ available-space>> [ 0 ] unless* ] }
+        { available-space [ available-space>> 0 or ] }
-        { free-space [ free-space>> [ 0 ] unless* ] }
+        { free-space [ free-space>> 0 or ] }
-        { used-space [ used-space>> [ 0 ] unless* ] }
+        { used-space [ used-space>> 0 or ] }
-        { total-space [ total-space>> [ 0 ] unless* ] }
+        { total-space [ total-space>> 0 or ] }
         { percent-used [
             [ used-space>> ] [ total-space>> ] bi
-            [ [ 0 ] unless* ] bi@ dup 0 =
+            [ 0 or ] bi@ dup 0 =
             [ 2drop 0 ] [ / percent ] if
         ] }
     } case ;
@@ -65,8 +115,10 @@ percent-used percent-free ;
     [ [ unparse ] map ] bi prefix simple-table. ;
 
 : file-systems. ( -- )
-    { device-name available-space free-space used-space total-space percent-used mount-point }
+    {
-    print-file-systems ;
+        device-name available-space free-space used-space
+        total-space percent-used mount-point
+    } print-file-systems ;
 
 {
     { [ os unix? ] [ "tools.files.unix" ] }

basis/tools/files/unix/unix.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators kernel system unicode.case io.files
-io.files.info io.files.info.unix tools.files generalizations
+io.files.info io.files.info.unix generalizations
 strings arrays sequences math.parser unix.groups unix.users
-tools.files.private unix.stat math fry macros combinators.smart ;
+tools.files.private unix.stat math fry macros combinators.smart
+io.files.info.unix io tools.files math.order prettyprint ;
 IN: tools.files.unix
 
 <PRIVATE
@@ -45,19 +46,23 @@ IN: tools.files.unix
     } cond ;
 
 M: unix (directory.) ( path -- lines )
-    [ [
+    <listing-tool>
-        [
+        { permissions nlinks user group file-size file-date file-name } >>specs
-            dup file-info [
+        { { directory-entry>> name>> <=> } } >>sort
+    [ [ list-files ] with-group-cache ] with-user-cache ;
+
+M: unix file-spec>string ( file-listing spec -- string )
     {
-                    [ permissions-string ]
+        { file-name/type [
-                    [ nlink>> number>string 3 CHAR: \s pad-left ]
+            directory-entry>> [ name>> ] [ file-type>trailing ] bi append
-                    [ uid>> user-name ]
+        ] }
-                    [ gid>> group-name ]
+        { permissions [ file-info>> permissions-string ] }
-                    [ size>> number>string 15 CHAR: \s pad-left ]
+        { nlinks [ file-info>> nlink>> number>string ] }
-                    [ modified>> ls-timestamp ]
+        { user [ file-info>> uid>> user-name ] }
-                } cleave
+        { group [ file-info>> gid>> group-name ] }
-            ] output>array swap suffix " " join
+        { uid [ file-info>> uid>> number>string ] }
-        ] map
+        { gid [ file-info>> gid>> number>string ] }
-    ] with-group-cache ] with-user-cache ;
+        [ call-next-method ]
+    } case ;
 
 PRIVATE>

basis/tools/files/windows/windows.factor

@@ -2,24 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors calendar.format combinators io.files
 kernel math.parser sequences splitting system tools.files
-generalizations tools.files.private io.files.info ;
+generalizations tools.files.private io.files.info math.order ;
 IN: tools.files.windows
 
 <PRIVATE
 
-: directory-or-size ( file-info -- str )
-    dup directory? [
-        drop "<DIR>" 20 CHAR: \s pad-right
-    ] [
-        size>> number>string 20 CHAR: \s pad-left
-    ] if ;
-
 M: windows (directory.) ( entries -- lines )
-    [
+    <listing-tool>
-        dup file-info {
+        { file-datetime directory-or-size file-name } >>specs
-            [ modified>> timestamp>ymdhms ]
+        { { directory-entry>> name>> <=> } } >>sort
-            [ directory-or-size ]
+    list-files ;
-        } cleave 2 narray swap suffix " " join
-    ] map ;
 
 PRIVATE>

basis/ui/gadgets/scrollers/scrollers.factor

@@ -37,13 +37,14 @@ scroller H{
     new-frame
         t >>root?
         <scroller-model> >>model
-        faint-boundary
 
-        dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
+        dup model>> dependencies>>
-        dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
+        [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
+        [ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
 
-        tuck model>> <viewport> >>viewport
+        tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
-        dup viewport>> @center grid-add ; inline
+
+        faint-boundary ; inline
 
 : <scroller> ( gadget -- scroller ) scroller new-scroller ;
 

basis/ui/gadgets/viewports/viewports.factor

@@ -1,18 +1,23 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: ui.gadgets.viewports
 USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors math.geometry.rect ;
+kernel math namespaces sequences models math.vectors
+math.geometry.rect ;
+IN: ui.gadgets.viewports
 
-: viewport-gap { 3 3 } ; inline
+CONSTANT: viewport-gap { 3 3 }
+CONSTANT: scroller-border { 1 1 }
 
 TUPLE: viewport < gadget ;
 
 : find-viewport ( gadget -- viewport )
     [ viewport? ] find-parent ;
 
+: viewport-padding ( -- padding )
+    viewport-gap 2 v*n scroller-border v+ ;
+
 : viewport-dim ( viewport -- dim )
-    gadget-child pref-dim viewport-gap 2 v*n v+ ;
+    gadget-child pref-dim viewport-padding v+ ;
 
 : <viewport> ( content model -- viewport )
     viewport new-gadget
@@ -21,11 +26,11 @@ TUPLE: viewport < gadget ;
         swap add-gadget ;
 
 M: viewport layout*
-    [
+    [ gadget-child ] [
-        [ rect-dim viewport-gap 2 v*n v- ]
+        [ dim>> viewport-padding v- ]
         [ gadget-child pref-dim ]
         bi vmax
-    ] [ gadget-child ] bi (>>dim) ;
+    ] bi >>dim drop ;
 
 M: viewport focusable-child*
     gadget-child ;
@@ -37,13 +42,17 @@ M: viewport pref-dim* viewport-dim ;
 
 M: viewport model-changed
     nip
-    dup relayout-1
+    [ relayout-1 ]
-    dup scroller-value
+    [
-    vneg viewport-gap v+
+        [ gadget-child ]
-    swap gadget-child (>>loc) ;
+        [
+            scroller-value vneg
+            viewport-gap v+
+            scroller-border v+
+        ] bi
+        >>loc drop
+    ] bi ;
 
 : visible-dim ( gadget -- dim )
     dup parent>> viewport?
-      [ parent>> rect-dim viewport-gap 2 v*n v- ]
+    [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;
-      [ rect-dim ]
-    if ;

core/strings/strings-tests.factor

@@ -108,7 +108,7 @@ unit-test
             ] times
             .
         ] times
-    ] with-null-stream
+    ] with-null-writer
 ] unit-test
 
 [ t ] [