steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Bruno Deferrari 2008-08-15 21:02:22 -03:00
parent 2a9f92f4cc a452dd86f6
commit 81bd76606e
28 changed files with 450 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/help/lint/lint.factor
View File

@ -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
vocabs.loader assocs editors continuations classes.predicate
macros math sets eval ;
combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
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 ] }
{ [ dup contains-funky-elements? not ] [ 2drop ] }
{ [ over macro? not ] [ 2drop ] }
[ drop "declared-effect" word-prop not ]
[ nip contains-funky-elements? ]
[ 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 [

12
basis/io/ports/ports.factor
View File

@ -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>> shutdown ]
tri
{
[ handle>> &dispose drop ]
[ buffer>> &dispose drop ]
[ port-flush ]
[ handle>> shutdown ]
} cleave
] with-destructors ;
M: buffered-port dispose*

9
basis/prettyprint/sections/sections.factor
View File

@ -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 [
dup rot call pprint-section
] with each ; inline
[
sections>> [ line-break? not ] filter
unclip-slice pprint-section
] dip
[ [ pprint-section ] bi ] curry each ; inline
M: block short-section ( block -- )
[ advance ] pprint-sections ;

1
basis/unix/bsd/bsd.factor
View File

@ -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

1
basis/unix/linux/linux.factor
View File

@ -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

3
basis/unix/unix.factor
View File

@ -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

6
extra/html/parser/analyzer/analyzer.factor
View File

@ -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

10
extra/html/parser/parser.factor
View File

@ -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 construct ;
tag new
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 ;

10
extra/html/parser/printer/printer.factor
View File

@ -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 ;

1
extra/io/serial/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

22
extra/io/serial/serial.factor Normal file
View File

@ -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

1
extra/io/serial/summary.txt Normal file
View File

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

1
extra/io/serial/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

86
extra/io/serial/unix/bsd/bsd.factor Normal file
View File

@ -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

1
extra/io/serial/unix/bsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

130
extra/io/serial/unix/linux/linux.factor Normal file
View File

@ -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 ;

1
extra/io/serial/unix/linux/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
extra/io/serial/unix/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

19
extra/io/serial/unix/termios/bsd/bsd.factor Normal file
View File

@ -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

1
extra/io/serial/unix/termios/bsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

20
extra/io/serial/unix/termios/linux/linux.factor Normal file
View File

@ -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

1
extra/io/serial/unix/termios/linux/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
extra/io/serial/unix/termios/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

9
extra/io/serial/unix/termios/termios.factor Normal file
View File

@ -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

21
extra/io/serial/unix/unix-tests.factor Normal file
View File

@ -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 ;

62
extra/io/serial/unix/unix.factor Normal file
View File

@ -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 ;

54
extra/irc/ui/ui.factor
View File

@ -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 )
[ timestamp>> ] [ 2drop now ] recover ;
GENERIC: time-happened ( message -- timestamp )
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 ;

11
extra/sequences/lib/lib.factor
View File

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