Merge branch 'master' of git://factorcode.org/git/factor

basis/help/lint/lint.factor

@@ -3,9 +3,9 @@
 USING: accessors sequences parser kernel help help.markup
 help.topics words strings classes tools.vocabs namespaces io
 io.streams.string prettyprint definitions arrays vectors
-combinators splitting debugger hashtables sorting effects vocabs
+combinators combinators.short-circuit splitting debugger
-vocabs.loader assocs editors continuations classes.predicate
+hashtables sorting effects vocabs vocabs.loader assocs editors
-macros math sets eval ;
+continuations classes.predicate macros math sets eval ;
 IN: help.lint
 
 : check-example ( element -- )
@@ -43,15 +43,15 @@ IN: help.lint
 
 : check-values ( word element -- )
     {
-        { [ over "declared-effect" word-prop ] [ 2drop ] }
+        [ drop "declared-effect" word-prop not ]
-        { [ dup contains-funky-elements? not ] [ 2drop ] }
+        [ nip contains-funky-elements? ]
-        { [ over macro? not ] [ 2drop ] }
+        [ drop macro? ]
         [
             [ effect-values >array ]
             [ extract-values >array ]
-            bi* assert=
+            bi* =
         ]
-    } cond ;
+    } 2|| [ "$values don't match stack effect" throw ] unless ;
 
 : check-see-also ( word element -- )
     nip \ $see-also swap elements [

basis/io/ports/ports.factor

@@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic
 byte-vectors system io.encodings math.order io.backend
 continuations debugger classes byte-arrays namespaces splitting
 grouping dlists assocs io.encodings.binary summary accessors
-destructors ;
+destructors combinators ;
 IN: io.ports
 
 SYMBOL: default-buffer-size
@@ -133,10 +133,12 @@ M: output-port stream-flush ( port -- )
 
 M: output-port dispose*
     [
-        [ handle>> &dispose drop ]
+        {
-        [ port-flush ]
+            [ handle>> &dispose drop ]
-        [ handle>> shutdown ]
+            [ buffer>> &dispose drop ]
-        tri
+            [ port-flush ]
+            [ handle>> shutdown ]
+        } cleave
     ] with-destructors ;
 
 M: buffered-port dispose*

basis/prettyprint/sections/sections.factor

@@ -171,10 +171,11 @@ M: block section-fits? ( section -- ? )
     line-limit? [ drop t ] [ call-next-method ] if ;
 
 : pprint-sections ( block advancer -- )
-    swap sections>> [ line-break? not ] filter
+    [
-    unclip pprint-section [
+        sections>> [ line-break? not ] filter
-        dup rot call pprint-section
+        unclip-slice pprint-section
-    ] with each ; inline
+    ] dip
+    [ [ pprint-section ] bi ] curry each ; inline
 
 M: block short-section ( block -- )
     [ advance ] pprint-sections ;

basis/unix/bsd/bsd.factor

@@ -16,6 +16,7 @@ IN: unix
 : O_TRUNC    HEX: 0400 ; inline
 : O_EXCL     HEX: 0800 ; inline
 : O_NOCTTY   HEX: 20000 ; inline
+: O_NDELAY O_NONBLOCK ; inline
 
 : SOL_SOCKET HEX: ffff ; inline
 : SO_REUSEADDR HEX: 4 ; inline

basis/unix/linux/linux.factor

@@ -16,6 +16,7 @@ USING: alien.syntax ;
 : O_TRUNC    HEX: 0200 ; inline
 : O_APPEND   HEX: 0400 ; inline
 : O_NONBLOCK HEX: 0800 ; inline
+: O_NDELAY O_NONBLOCK ; inline
 
 : SOL_SOCKET 1 ; inline
 

basis/unix/unix.factor

@@ -25,8 +25,6 @@ TYPEDEF: uint socklen_t
 
 : NGROUPS_MAX 16 ; inline
 
-: O_NDELAY O_NONBLOCK ; inline
-
 C-STRUCT: group
     { "char*" "gr_name" }
     { "char*" "gr_passwd" }
@@ -194,4 +192,3 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
     { [ os bsd? ] [ "unix.bsd" require ] }
     { [ os solaris? ] [ "unix.solaris" require ] }
 } cond
-

extra/html/parser/analyzer/analyzer.factor

@@ -140,6 +140,12 @@ TUPLE: link attributes clickable ;
 : href-contains? ( str tag -- ? )
     attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
 
+: find-hrefs ( vector -- vector' )
+    find-links
+    [ [
+        [ name>> "a" = ]
+        [ attributes>> "href" swap key? ] bi and ] filter
+    ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
 
 : find-forms ( vector -- vector' )
     "form" over find-opening-tags-by-name

extra/html/parser/parser.factor

@@ -1,4 +1,4 @@
-USING: arrays html.parser.utils hashtables io kernel
+USING: accessors arrays html.parser.utils hashtables io kernel
 namespaces prettyprint quotations
 sequences splitting state-parser strings unicode.categories unicode.case ;
 IN: html.parser
@@ -23,8 +23,10 @@ SYMBOL: tagstack
     ] if ;
 
 : <tag> ( name attributes closing? -- tag )
-    { set-tag-name set-tag-attributes set-tag-closing? }
+    tag new
-    tag construct ;
+        swap >>closing?
+        swap >>attributes
+        swap >>name ;
 
 : make-tag ( str attribs -- tag )
     >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
@@ -75,7 +77,7 @@ SYMBOL: tagstack
         read-quote
     ] [
         read-token
-    ] if ;
+    ] if [ blank? ] trim ;
 
 : read-comment ( -- )
     "-->" take-string* make-comment-tag push-tag ;

extra/html/parser/printer/printer.factor

@@ -83,13 +83,6 @@ M: src-printer print-closing-named-tag ( tag -- )
 SYMBOL: tab-width
 SYMBOL: #indentations
 
-: html-pp ( vector -- )
-    [
-        0 #indentations set
-        2 tab-width set
-        
-    ] with-scope ;
-
 : print-tabs ( -- )
     tab-width get #indentations get * CHAR: \s <repetition> write ; 
 
@@ -125,3 +118,6 @@ M: printer print-tag ( tag -- )
 ! H{ { table-gap { 10 10 } } } [
     ! [ [ [ [ . ] with-cell ] each ] with-row ] each
 ! ] tabular-output
+
+! : html-pp ( vector -- )
+    ! [ 0 #indentations set 2 tab-width set ] with-scope ; 

extra/io/serial/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/io/serial/serial.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators destructors
+kernel math math.bitfields math.parser sequences summary system
+vocabs.loader ;
+IN: io.serial
+
+TUPLE: serial stream path baud 
+    termios iflag oflag cflag lflag ;
+
+ERROR: invalid-baud baud ;
+M: invalid-baud summary ( invalid-baud -- string )
+    "Baud rate "
+    swap baud>> number>string
+    " not supported" 3append ;
+
+HOOK: lookup-baud os ( m -- n )
+HOOK: open-serial os ( serial -- stream )
+
+{
+    { [ os unix? ] [ "io.serial.unix" ] } 
+} cond require

extra/io/serial/summary.txt

@@ -0,0 +1 @@
+Serial port library

extra/io/serial/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/bsd/bsd.factor

@@ -0,0 +1,86 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math.bitfields sequences system io.serial ;
+IN: io.serial.unix
+
+M: bsd lookup-baud ( m -- n )
+    dup {
+        0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
+        7200 9600 14400 19200 28800 38400 57600 76800 115200
+        230400 460800 921600
+    } member? [ invalid-baud ] unless ;
+
+: TCSANOW     0 ; inline
+: TCSADRAIN   1 ; inline
+: TCSAFLUSH   2 ; inline
+: TCSASOFT    HEX: 10 ; inline
+
+: TCIFLUSH    1 ; inline
+: TCOFLUSH    2 ; inline
+: TCIOFLUSH   3 ; inline
+: TCOOFF      1 ; inline
+: TCOON       2 ; inline
+: TCIOFF      3 ; inline
+: TCION       4 ; inline
+
+! iflags
+: IGNBRK      HEX: 00000001 ; inline
+: BRKINT      HEX: 00000002 ; inline
+: IGNPAR      HEX: 00000004 ; inline
+: PARMRK      HEX: 00000008 ; inline
+: INPCK       HEX: 00000010 ; inline
+: ISTRIP      HEX: 00000020 ; inline
+: INLCR       HEX: 00000040 ; inline
+: IGNCR       HEX: 00000080 ; inline
+: ICRNL       HEX: 00000100 ; inline
+: IXON        HEX: 00000200 ; inline
+: IXOFF       HEX: 00000400 ; inline
+: IXANY       HEX: 00000800 ; inline
+: IMAXBEL     HEX: 00002000 ; inline
+: IUTF8       HEX: 00004000 ; inline
+
+! oflags
+: OPOST       HEX: 00000001 ; inline
+: ONLCR       HEX: 00000002 ; inline
+: OXTABS      HEX: 00000004 ; inline
+: ONOEOT      HEX: 00000008 ; inline
+
+! cflags
+: CIGNORE     HEX: 00000001 ; inline
+: CSIZE       HEX: 00000300 ; inline
+: CS5         HEX: 00000000 ; inline
+: CS6         HEX: 00000100 ; inline
+: CS7         HEX: 00000200 ; inline
+: CS8         HEX: 00000300 ; inline
+: CSTOPB      HEX: 00000400 ; inline
+: CREAD       HEX: 00000800 ; inline
+: PARENB      HEX: 00001000 ; inline
+: PARODD      HEX: 00002000 ; inline
+: HUPCL       HEX: 00004000 ; inline
+: CLOCAL      HEX: 00008000 ; inline
+: CCTS_OFLOW  HEX: 00010000 ; inline
+: CRTS_IFLOW  HEX: 00020000 ; inline
+: CRTSCTS     { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+: CDTR_IFLOW  HEX: 00040000 ; inline
+: CDSR_OFLOW  HEX: 00080000 ; inline
+: CCAR_OFLOW  HEX: 00100000 ; inline
+: MDMBUF      HEX: 00100000 ; inline
+
+! lflags
+: ECHOKE      HEX: 00000001 ; inline
+: ECHOE       HEX: 00000002 ; inline
+: ECHOK       HEX: 00000004 ; inline
+: ECHO        HEX: 00000008 ; inline
+: ECHONL      HEX: 00000010 ; inline
+: ECHOPRT     HEX: 00000020 ; inline
+: ECHOCTL     HEX: 00000040 ; inline
+: ISIG        HEX: 00000080 ; inline
+: ICANON      HEX: 00000100 ; inline
+: ALTWERASE   HEX: 00000200 ; inline
+: IEXTEN      HEX: 00000400 ; inline
+: EXTPROC     HEX: 00000800 ; inline
+: TOSTOP      HEX: 00400000 ; inline
+: FLUSHO      HEX: 00800000 ; inline
+: NOKERNINFO  HEX: 02000000 ; inline
+: PENDIN      HEX: 20000000 ; inline
+: NOFLSH      HEX: 80000000 ; inline

extra/io/serial/unix/bsd/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/linux/linux.factor

@@ -0,0 +1,130 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs alien.syntax kernel io.serial system unix ;
+IN: io.serial.unix
+
+: TCSANOW     0 ; inline
+: TCSADRAIN   1 ; inline
+: TCSAFLUSH   2 ; inline
+
+: TCIFLUSH    0 ; inline
+: TCOFLUSH    1 ; inline
+: TCIOFLUSH   2 ; inline
+
+: TCOOFF      0 ; inline
+: TCOON       1 ; inline
+: TCIOFF      2 ; inline
+: TCION       3 ; inline
+
+! iflag
+: IGNBRK  OCT: 0000001 ; inline
+: BRKINT  OCT: 0000002 ; inline
+: IGNPAR  OCT: 0000004 ; inline
+: PARMRK  OCT: 0000010 ; inline
+: INPCK   OCT: 0000020 ; inline
+: ISTRIP  OCT: 0000040 ; inline
+: INLCR   OCT: 0000100 ; inline
+: IGNCR   OCT: 0000200 ; inline
+: ICRNL   OCT: 0000400 ; inline
+: IUCLC   OCT: 0001000 ; inline
+: IXON    OCT: 0002000 ; inline
+: IXANY   OCT: 0004000 ; inline
+: IXOFF   OCT: 0010000 ; inline
+: IMAXBEL OCT: 0020000 ; inline
+: IUTF8   OCT: 0040000 ; inline
+
+! oflag
+: OPOST   OCT: 0000001 ; inline
+: OLCUC   OCT: 0000002 ; inline
+: ONLCR   OCT: 0000004 ; inline
+: OCRNL   OCT: 0000010 ; inline
+: ONOCR   OCT: 0000020 ; inline
+: ONLRET  OCT: 0000040 ; inline
+: OFILL   OCT: 0000100 ; inline
+: OFDEL   OCT: 0000200 ; inline
+: NLDLY  OCT: 0000400 ; inline
+:   NL0  OCT: 0000000 ; inline
+:   NL1  OCT: 0000400 ; inline
+: CRDLY  OCT: 0003000 ; inline
+:   CR0  OCT: 0000000 ; inline
+:   CR1  OCT: 0001000 ; inline
+:   CR2  OCT: 0002000 ; inline
+:   CR3  OCT: 0003000 ; inline
+: TABDLY OCT: 0014000 ; inline
+:   TAB0 OCT: 0000000 ; inline
+:   TAB1 OCT: 0004000 ; inline
+:   TAB2 OCT: 0010000 ; inline
+:   TAB3 OCT: 0014000 ; inline
+: BSDLY  OCT: 0020000 ; inline
+:   BS0  OCT: 0000000 ; inline
+:   BS1  OCT: 0020000 ; inline
+: FFDLY  OCT: 0100000 ; inline
+:   FF0  OCT: 0000000 ; inline
+:   FF1  OCT: 0100000 ; inline
+
+! cflags
+: CSIZE   OCT: 0000060 ; inline
+:   CS5   OCT: 0000000 ; inline
+:   CS6   OCT: 0000020 ; inline
+:   CS7   OCT: 0000040 ; inline
+:   CS8   OCT: 0000060 ; inline
+: CSTOPB  OCT: 0000100 ; inline
+: CREAD   OCT: 0000200 ; inline
+: PARENB  OCT: 0000400 ; inline
+: PARODD  OCT: 0001000 ; inline
+: HUPCL   OCT: 0002000 ; inline
+: CLOCAL  OCT: 0004000 ; inline
+: CIBAUD  OCT: 002003600000 ; inline
+: CRTSCTS OCT: 020000000000 ; inline
+
+! lflags
+: ISIG    OCT: 0000001 ; inline
+: ICANON  OCT: 0000002 ; inline
+: XCASE  OCT: 0000004 ; inline
+: ECHO    OCT: 0000010 ; inline
+: ECHOE   OCT: 0000020 ; inline
+: ECHOK   OCT: 0000040 ; inline
+: ECHONL  OCT: 0000100 ; inline
+: NOFLSH  OCT: 0000200 ; inline
+: TOSTOP  OCT: 0000400 ; inline
+: ECHOCTL OCT: 0001000 ; inline
+: ECHOPRT OCT: 0002000 ; inline
+: ECHOKE  OCT: 0004000 ; inline
+: FLUSHO  OCT: 0010000 ; inline
+: PENDIN  OCT: 0040000 ; inline
+: IEXTEN  OCT: 0100000 ; inline
+
+M: linux lookup-baud ( n -- n )
+    dup H{
+        { 0 OCT: 0000000 }
+        { 50    OCT: 0000001 }
+        { 75    OCT: 0000002 }
+        { 110   OCT: 0000003 }
+        { 134   OCT: 0000004 }
+        { 150   OCT: 0000005 }
+        { 200   OCT: 0000006 }
+        { 300   OCT: 0000007 }
+        { 600   OCT: 0000010 }
+        { 1200  OCT: 0000011 }
+        { 1800  OCT: 0000012 }
+        { 2400  OCT: 0000013 }
+        { 4800  OCT: 0000014 }
+        { 9600  OCT: 0000015 }
+        { 19200 OCT: 0000016 }
+        { 38400 OCT: 0000017 }
+        { 57600   OCT: 0010001 }
+        { 115200  OCT: 0010002 }
+        { 230400  OCT: 0010003 }
+        { 460800  OCT: 0010004 }
+        { 500000  OCT: 0010005 }
+        { 576000  OCT: 0010006 }
+        { 921600  OCT: 0010007 }
+        { 1000000 OCT: 0010010 }
+        { 1152000 OCT: 0010011 }
+        { 1500000 OCT: 0010012 }
+        { 2000000 OCT: 0010013 }
+        { 2500000 OCT: 0010014 }
+        { 3000000 OCT: 0010015 }
+        { 3500000 OCT: 0010016 }
+        { 4000000 OCT: 0010017 }
+    } at* [ nip ] [ drop invalid-baud ] if ;

extra/io/serial/unix/linux/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/termios/bsd/bsd.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences system ;
+IN: io.serial.unix.termios
+
+: NCCS 20 ; inline
+
+TYPEDEF: uint tcflag_t
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+
+C-STRUCT: termios
+    { "tcflag_t" "iflag" }           !  input mode flags
+    { "tcflag_t" "oflag" }           !  output mode flags
+    { "tcflag_t" "cflag" }           !  control mode flags
+    { "tcflag_t" "lflag" }           !  local mode flags
+    { { "cc_t" NCCS } "cc" }         !  control characters
+    { "speed_t" "ispeed" }           !  input speed
+    { "speed_t" "ospeed" } ;         !  output speed

extra/io/serial/unix/termios/bsd/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/termios/linux/linux.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel system unix ;
+IN: io.serial.unix.termios
+
+: NCCS 32 ; inline
+
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+TYPEDEF: uint tcflag_t
+
+C-STRUCT: termios
+    { "tcflag_t" "iflag" }           !  input mode flags
+    { "tcflag_t" "oflag" }           !  output mode flags
+    { "tcflag_t" "cflag" }           !  control mode flags
+    { "tcflag_t" "lflag" }           !  local mode flags
+    { "cc_t" "line" }                !  line discipline
+    { { "cc_t" NCCS } "cc" }         !  control characters
+    { "speed_t" "ispeed" }           !  input speed
+    { "speed_t" "ospeed" } ;         !  output speed

extra/io/serial/unix/termios/linux/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/termios/tags.txt

@@ -0,0 +1 @@
+unportable

extra/io/serial/unix/termios/termios.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: io.serial.unix.termios
+
+{
+    { [ os linux? ] [ "io.serial.unix.termios.linux" ] }
+    { [ os bsd? ] [ "io.serial.unix.termios.bsd" ] }
+} cond require

extra/io/serial/unix/unix-tests.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math.bitfields serial serial.unix ;
+IN: io.serial.unix
+
+: serial-obj ( -- obj )
+    serial new
+    "/dev/ttyS0" >>path
+    19200 >>baud
+    { IGNPAR ICRNL } flags >>iflag
+    { } flags >>oflag
+    { CS8 CLOCAL CREAD } flags >>cflag
+    { ICANON } flags >>lflag ;
+
+: serial-test ( -- serial )
+    serial-obj
+    open-serial
+    dup get-termios >>termios
+    dup configure-termios
+    dup tciflush
+    dup apply-termios ;

extra/io/serial/unix/unix.factor

@@ -0,0 +1,62 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators io.ports
+io.streams.duplex io.unix.backend system kernel math math.bitfields
+vocabs.loader unix io.serial io.serial.unix.termios ;
+IN: io.serial.unix
+
+<< {
+    { [ os linux? ] [ "io.serial.unix.linux" ] }
+    { [ os bsd? ] [ "io.serial.unix.bsd" ] }
+} cond require >>
+
+FUNCTION: speed_t cfgetispeed ( termios* t ) ;
+FUNCTION: speed_t cfgetospeed ( termios* t ) ;
+FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
+FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
+FUNCTION: int tcgetattr ( int i1, termios* t ) ;
+FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
+FUNCTION: int tcdrain ( int i1 ) ;
+FUNCTION: int tcflow ( int i1, int i2 ) ;
+FUNCTION: int tcflush ( int i1, int i2 ) ;
+FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
+FUNCTION: void cfmakeraw ( termios* t ) ;
+FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
+
+: fd>duplex-stream ( fd -- duplex-stream )
+    <fd> init-fd
+    [ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
+
+: open-rw ( path -- fd ) O_RDWR file-mode open-file  ;
+: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
+
+M: unix open-serial ( serial -- serial' )
+    path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+    fd>duplex-stream ;
+
+: serial-fd ( serial -- fd )
+    stream>> in>> handle>> fd>> ;
+
+: get-termios ( serial -- termios )
+    serial-fd
+    "termios" <c-object> [ tcgetattr io-error ] keep ;
+
+: configure-termios ( serial -- )
+    dup termios>>
+    {
+        [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
+        [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
+        [
+            [
+                [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
+            ] dip set-termios-cflag
+        ]
+        [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
+    } 2cleave ;
+
+: tciflush ( serial -- )
+    serial-fd TCIFLUSH tcflush io-error ;
+
+: apply-termios ( serial -- )
+    [ serial-fd TCSANOW ]
+    [ termios>> ] bi tcsetattr io-error ;

extra/irc/ui/ui.factor

@@ -8,7 +8,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
        ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
        io io.styles namespaces calendar calendar.format models continuations
-       irc.client irc.client.private irc.messages irc.messages.private
+       irc.client irc.client.private irc.messages
        irc.ui.commandparser irc.ui.load ;
 
 RENAME: join sequences => sjoin
@@ -21,7 +21,10 @@ SYMBOL: client
 
 TUPLE: ui-window < tabbed client ;
 
-TUPLE: irc-tab < frame listener client window userlist ;
+M: ui-window ungraft*
+    client>> terminate-irc ;
+
+TUPLE: irc-tab < frame listener client window ;
 
 : write-color ( str color -- )
     foreground associate format ;
@@ -39,7 +42,7 @@ M: ping write-irc
 
 M: privmsg write-irc
     "<" blue write-color
-    [ prefix>> parse-name write ] keep
+    [ irc-message-sender write ] keep
     "> " blue write-color
     trailing>> write ;
 
@@ -61,24 +64,24 @@ M: own-message write-irc
 
 M: join write-irc
     "* " dark-green write-color
-    prefix>> parse-name write
+    irc-message-sender write
     " has entered the channel." dark-green write-color ;
 
 M: part write-irc
     "* " dark-red write-color
-    [ prefix>> parse-name write ] keep
+    [ irc-message-sender write ] keep
     " has left the channel" dark-red write-color
     trailing>> dot-or-parens dark-red write-color ;
 
 M: quit write-irc
     "* " dark-red write-color
-    [ prefix>> parse-name write ] keep
+    [ irc-message-sender write ] keep
     " has left IRC" dark-red write-color
     trailing>> dot-or-parens dark-red write-color ;
 
 M: kick write-irc
     "* " dark-red write-color
-    [ prefix>> parse-name write ] keep
+    [ irc-message-sender write ] keep
     " has kicked " dark-red write-color
     [ who>> write ] keep
     " from the channel" dark-red write-color
@@ -89,7 +92,7 @@ M: kick write-irc
 
 M: mode write-irc
     "* " blue write-color
-    [ prefix>> parse-name write ] keep
+    [ irc-message-sender write ] keep
     " has applied mode " blue write-color
     [ full-mode write ] keep
     " to " blue write-color
@@ -97,7 +100,7 @@ M: mode write-irc
 
 M: nick write-irc
     "* " blue write-color
-    [ prefix>> parse-name write ] keep
+    [ irc-message-sender write ] keep
     " is now known as " blue write-color
     trailing>> write ;
 
@@ -120,8 +123,11 @@ M: irc-listener-end write-irc
 M: irc-message write-irc
     drop ; ! catch all unimplemented writes, THIS WILL CHANGE    
 
-: time-happened ( irc-message -- timestamp )
+GENERIC: time-happened ( message -- timestamp )
-    [ timestamp>> ] [ 2drop now ] recover ;
+
+M: irc-message time-happened timestamp>> ;
+
+M: object time-happened drop now ;
 
 : print-irc ( irc-message -- )
     [ time-happened timestamp>hms write " " write ]
@@ -139,16 +145,6 @@ GENERIC: handle-inbox ( tab message -- )
 : add-gadget-color ( pack seq color -- pack )
     '[ , >>color add-gadget ] each ;
 
-: update-participants ( tab -- )
-    [ userlist>> [ clear-gadget ] keep ]
-    [ listener>> participants>> ] bi
-    [ +operator+ value-labels dark-green add-gadget-color ]
-    [ +voice+ value-labels blue add-gadget-color ]
-    [ +normal+ value-labels black add-gadget-color ] tri drop ;
-
-M: participant-changed handle-inbox
-    drop update-participants ;
-
 M: object handle-inbox
     nip print-irc ;
 
@@ -195,18 +191,24 @@ M: irc-tab ungraft*
 TUPLE: irc-channel-tab < irc-tab userlist ;
 
 : <irc-channel-tab> ( listener ui-window -- irc-tab )
-    irc-tab new-irc-tab
+    irc-channel-tab new-irc-tab
     <pile> [ <scroller> @right grid-add ] keep >>userlist ;
 
+: update-participants ( tab -- )
+    [ userlist>> [ clear-gadget ] keep ]
+    [ listener>> participants>> ] bi
+    [ +operator+ value-labels dark-green add-gadget-color ]
+    [ +voice+ value-labels blue add-gadget-color ]
+    [ +normal+ value-labels black add-gadget-color ] tri drop ;
+
+M: participant-changed handle-inbox
+    drop update-participants ;
+
 TUPLE: irc-server-tab < irc-tab ;
 
 : <irc-server-tab> ( listener -- irc-tab )
     f irc-server-tab new-irc-tab ;
 
-M: irc-server-tab ungraft*
-    [ window>> client>> terminate-irc ]
-    [ listener>> ] [ window>> client>> ] tri remove-listener ;
-
 : <irc-nick-tab> ( listener ui-window -- irc-tab )
     irc-tab new-irc-tab ;
 

extra/sequences/lib/lib.factor

@@ -211,8 +211,11 @@ PRIVATE>
 : insert-nth ( elt n seq -- seq' )
     swap cut-slice [ swap 1array ] dip 3append ;
 
-: if-seq ( seq quot1 quot2 -- )
+: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline
-    [ f like ] 2dip if* ; inline
+ 
+: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline
+
+: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
+
+: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
 
-: if-empty ( seq quot1 quot2 -- )
-    swap if-seq ; inline