Merge branch 'master' of git://factorcode.org/git/factor
commit
bb39a62269
|
@ -43,29 +43,17 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: word-inputs ( word -- seq )
|
||||
stack-effect [
|
||||
[ datastack ] dip in>> length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
: stack-values ( names -- alist )
|
||||
[ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
|
||||
|
||||
: entering ( str -- )
|
||||
"/-- Entering: " write dup .
|
||||
word-inputs stack.
|
||||
"\\--" print flush ;
|
||||
: trace-message ( word quot str -- )
|
||||
"--- " write write bl over .
|
||||
[ stack-effect ] dip '[ @ stack-values ] [ f ] if*
|
||||
[ simple-table. ] unless-empty flush ; inline
|
||||
|
||||
: word-outputs ( word -- seq )
|
||||
stack-effect [
|
||||
[ datastack ] dip out>> length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
: entering ( str -- ) [ in>> ] "Entering" trace-message ;
|
||||
|
||||
: leaving ( str -- )
|
||||
"/-- Leaving: " write dup .
|
||||
word-outputs stack.
|
||||
"\\--" print flush ;
|
||||
: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
|
||||
|
||||
: (watch) ( word def -- def )
|
||||
over '[ _ entering @ _ leaving ] ;
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
USING: math tools.test classes.algebra words kernel sequences assocs ;
|
||||
IN: classes.predicate
|
||||
USING: math tools.test classes.algebra words kernel sequences assocs
|
||||
accessors eval definitions compiler.units generic ;
|
||||
IN: classes.predicate.tests
|
||||
|
||||
PREDICATE: negative < integer 0 < ;
|
||||
PREDICATE: positive < integer 0 > ;
|
||||
|
@ -18,4 +19,16 @@ M: positive abs ;
|
|||
|
||||
[ 10 ] [ -10 abs ] unit-test
|
||||
[ 10 ] [ 10 abs ] unit-test
|
||||
[ 0 ] [ 0 abs ] unit-test
|
||||
[ 0 ] [ 0 abs ] unit-test
|
||||
|
||||
! Bug report from Bruno Deferrari
|
||||
TUPLE: tuple-a slot ;
|
||||
TUPLE: tuple-b < tuple-a ;
|
||||
|
||||
PREDICATE: tuple-c < tuple-b slot>> ;
|
||||
|
||||
GENERIC: ptest ( tuple -- )
|
||||
M: tuple-a ptest drop ;
|
||||
IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ;
|
||||
|
||||
[ ] [ tuple-b new ptest ] unit-test
|
||||
|
|
|
@ -58,13 +58,13 @@ M: single-combination make-default-method
|
|||
] unless ;
|
||||
|
||||
! 1. Flatten methods
|
||||
TUPLE: predicate-engine methods ;
|
||||
TUPLE: predicate-engine class methods ;
|
||||
|
||||
: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
|
||||
C: <predicate-engine> predicate-engine
|
||||
|
||||
: push-method ( method specializer atomic assoc -- )
|
||||
[
|
||||
[ H{ } clone <predicate-engine> ] unless*
|
||||
dupd [
|
||||
[ ] [ H{ } clone <predicate-engine> ] ?if
|
||||
[ methods>> set-at ] keep
|
||||
] change-at ;
|
||||
|
||||
|
@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine
|
|||
[ <enum> swap update ] keep
|
||||
] with-variable ;
|
||||
|
||||
PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
|
||||
|
||||
SYMBOL: predicate-engines
|
||||
|
||||
: sort-methods ( assoc -- assoc' )
|
||||
>alist [ keys sort-classes ] keep extract-keys ;
|
||||
|
||||
: quote-methods ( assoc -- assoc' )
|
||||
[ 1quotation \ drop prefix ] assoc-map ;
|
||||
|
||||
: find-predicate-engine ( classes -- word )
|
||||
predicate-engines get [ at ] curry map-find drop ;
|
||||
|
||||
: next-predicate-engine ( engine -- word )
|
||||
class>> superclasses
|
||||
find-predicate-engine
|
||||
default get or ;
|
||||
|
||||
: methods-with-default ( engine -- assoc )
|
||||
methods>> clone default get object bootstrap-word pick set-at ;
|
||||
[ methods>> clone ] [ next-predicate-engine ] bi
|
||||
object bootstrap-word pick set-at ;
|
||||
|
||||
: keep-going? ( assoc -- ? )
|
||||
assumed get swap second first class<= ;
|
||||
|
@ -205,8 +218,6 @@ M: tuple-dispatch-engine compile-engine
|
|||
: class-predicates ( assoc -- assoc )
|
||||
[ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
|
||||
|
||||
PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
|
||||
|
||||
: <predicate-engine-word> ( -- word )
|
||||
generic-word get name>> "/predicate-engine" append f <word>
|
||||
dup generic-word get "owner-generic" set-word-prop ;
|
||||
|
@ -217,7 +228,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
|
|||
[ <predicate-engine-word> ] dip
|
||||
[ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
|
||||
|
||||
M: predicate-engine compile-engine
|
||||
: compile-predicate-engine ( engine -- word )
|
||||
methods-with-default
|
||||
sort-methods
|
||||
quote-methods
|
||||
|
@ -225,6 +236,10 @@ M: predicate-engine compile-engine
|
|||
class-predicates
|
||||
[ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
|
||||
|
||||
M: predicate-engine compile-engine
|
||||
[ compile-predicate-engine ] [ class>> ] bi
|
||||
[ drop ] [ predicate-engines get set-at ] 2bi ;
|
||||
|
||||
M: word compile-engine ;
|
||||
|
||||
M: f compile-engine ;
|
||||
|
@ -251,6 +266,7 @@ HOOK: mega-cache-quot combination ( methods -- quot/f )
|
|||
|
||||
M: single-combination perform-combination
|
||||
[
|
||||
H{ } clone predicate-engines set
|
||||
dup generic-word set
|
||||
dup build-decision-tree
|
||||
[ "decision-tree" set-word-prop ]
|
||||
|
|
|
@ -19,7 +19,7 @@ SYMBOL: current-irc-client
|
|||
|
||||
UNION: to-target privmsg notice ;
|
||||
UNION: to-channel join part topic kick rpl-channel-modes
|
||||
rpl-notopic rpl-topic rpl-names rpl-names-end ;
|
||||
topic rpl-names rpl-names-end ;
|
||||
UNION: to-one-chat to-target to-channel mode ;
|
||||
UNION: to-many-chats nick quit ;
|
||||
UNION: to-all-chats irc-end irc-disconnected irc-connected ;
|
||||
|
|
|
@ -33,7 +33,8 @@ TUPLE: irc-profile server port nickname password ;
|
|||
C: <irc-profile> irc-profile
|
||||
|
||||
TUPLE: irc-client profile stream in-messages out-messages
|
||||
chats is-running nick connect reconnect-time is-ready
|
||||
chats is-running nick connect is-ready
|
||||
reconnect-time reconnect-attempts
|
||||
exceptions ;
|
||||
|
||||
: <irc-client> ( profile -- irc-client )
|
||||
|
@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages
|
|||
<mailbox> >>in-messages
|
||||
<mailbox> >>out-messages
|
||||
H{ } clone >>chats
|
||||
15 seconds >>reconnect-time
|
||||
30 seconds >>reconnect-time
|
||||
10 >>reconnect-attempts
|
||||
V{ } clone >>exceptions
|
||||
[ <inet> latin1 <client> ] >>connect ;
|
||||
[ <inet> latin1 <client> drop ] >>connect ;
|
||||
|
||||
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
|
||||
|
|
|
@ -76,7 +76,7 @@ M: mb-writer dispose drop ;
|
|||
! Test connect
|
||||
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
|
||||
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
|
||||
[ 2drop <test-stream> t ] >>connect
|
||||
[ 2drop <test-stream> ] >>connect
|
||||
[
|
||||
(connect-irc)
|
||||
(do-login)
|
||||
|
|
|
@ -3,10 +3,17 @@
|
|||
USING: accessors assocs arrays concurrency.mailboxes continuations destructors
|
||||
hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
|
||||
strings words.symbol irc.messages.base irc.client.participants fry threads
|
||||
combinators irc.messages.parser ;
|
||||
combinators irc.messages.parser math ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client.internals
|
||||
|
||||
: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
|
||||
dup 0 > [
|
||||
[ drop call( host port -- stream ) ]
|
||||
[ drop 15 sleep 1- do-connect ]
|
||||
recover
|
||||
] [ 2drop 2drop f ] if ;
|
||||
|
||||
: /NICK ( nick -- ) "NICK " prepend irc-print ;
|
||||
: /PONG ( text -- ) "PONG " prepend irc-print ;
|
||||
|
||||
|
@ -15,18 +22,27 @@ IN: irc.client.internals
|
|||
"USER " prepend " hostname servername :irc.factor" append irc-print ;
|
||||
|
||||
: /CONNECT ( server port -- stream )
|
||||
irc> connect>> call( host port -- stream local ) drop ;
|
||||
irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
|
||||
|
||||
: /JOIN ( channel password -- )
|
||||
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
|
||||
|
||||
: try-connect ( -- stream/f )
|
||||
irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
|
||||
|
||||
: (terminate-irc) ( -- )
|
||||
irc> dup is-running>> [
|
||||
f >>is-running
|
||||
[ stream>> dispose ] keep
|
||||
[ in-messages>> ] [ out-messages>> ] bi 2array
|
||||
[ irc-end swap mailbox-put ] each
|
||||
] [ drop ] if ;
|
||||
|
||||
: (connect-irc) ( -- )
|
||||
irc> {
|
||||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
|
||||
[ (>>stream) ]
|
||||
[ t swap (>>is-running) ]
|
||||
[ in-messages>> [ irc-connected ] dip mailbox-put ]
|
||||
} cleave ;
|
||||
try-connect [
|
||||
[ irc> ] dip >>stream t >>is-running
|
||||
in-messages>> [ irc-connected ] dip mailbox-put
|
||||
] [ (terminate-irc) ] if* ;
|
||||
|
||||
: (do-login) ( -- ) irc> nick>> /LOGIN ;
|
||||
|
||||
|
@ -52,7 +68,7 @@ M: to-all-chats message-forwards drop chats> ;
|
|||
M: to-many-chats message-forwards sender>> participant-chats ;
|
||||
|
||||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
M: object process-message drop ;
|
||||
M: ping process-message trailing>> /PONG ;
|
||||
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
|
||||
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
|
||||
|
@ -92,9 +108,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
|||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc-disconnected irc> in-messages>> mailbox-put
|
||||
irc> reconnect-time>> sleep
|
||||
(connect-irc)
|
||||
(do-login) ;
|
||||
(connect-irc) (do-login) ;
|
||||
|
||||
: handle-disconnect ( error -- ? )
|
||||
[ irc> exceptions>> push ] when*
|
||||
|
@ -155,12 +169,4 @@ M: irc-channel-chat remove-chat
|
|||
[ part new annotate-message irc-send ]
|
||||
[ name>> unregister-chat ] bi ;
|
||||
|
||||
: (terminate-irc) ( -- )
|
||||
irc> dup is-running>> [
|
||||
f >>is-running
|
||||
[ stream>> dispose ] keep
|
||||
[ in-messages>> ] [ out-messages>> ] bi 2array
|
||||
[ irc-end swap mailbox-put ] each
|
||||
] [ drop ] if ;
|
||||
|
||||
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
|
||||
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
|
||||
|
|
|
@ -11,6 +11,12 @@ GENERIC: >log-line ( object -- line )
|
|||
|
||||
M: irc-message >log-line line>> ;
|
||||
|
||||
M: ctcp >log-line
|
||||
[ "CTCP: " % dup sender>> % " " % text>> % ] "" make ;
|
||||
|
||||
M: action >log-line
|
||||
[ "* " % dup sender>> % " " % text>> % ] "" make ;
|
||||
|
||||
M: privmsg >log-line
|
||||
[ "<" % dup sender>> % "> " % text>> % ] "" make ;
|
||||
|
||||
|
@ -35,3 +41,7 @@ M: participant-mode >log-line
|
|||
|
||||
M: nick >log-line
|
||||
[ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
|
||||
|
||||
M: topic >log-line
|
||||
[ "* " % dup sender>> % " has set the topic for " % dup channel>> %
|
||||
": \"" % topic>> % "\"" % ] "" make ;
|
||||
|
|
|
@ -16,7 +16,7 @@ SYMBOL: current-stream
|
|||
"irc.freenode.org" 6667 "flogger" f <irc-profile> ;
|
||||
|
||||
: add-timestamp ( string timestamp -- string )
|
||||
timestamp>hms "[" prepend "] " append prepend ;
|
||||
timestamp>hms [ "[" % % "] " % % ] "" make ;
|
||||
|
||||
: timestamp-path ( timestamp -- path )
|
||||
timestamp>ymd ".log" append log-directory prepend-path ;
|
||||
|
@ -27,7 +27,7 @@ SYMBOL: current-stream
|
|||
] [
|
||||
current-stream get [ dispose ] when*
|
||||
[ day-of-year current-day set ]
|
||||
[ timestamp-path latin1 <file-writer> ] bi
|
||||
[ timestamp-path latin1 <file-appender> ] bi
|
||||
current-stream set
|
||||
] if current-stream get ;
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
USING: accessors arrays assocs calendar classes.parser classes.tuple
|
||||
combinators fry generic.parser kernel lexer
|
||||
mirrors namespaces parser sequences splitting strings words ;
|
||||
IN: irc.messages.base
|
||||
|
@ -51,6 +51,7 @@ M: irc-message post-process-irc-message drop ;
|
|||
|
||||
GENERIC: fill-irc-message-slots ( irc-message -- )
|
||||
M: irc-message fill-irc-message-slots
|
||||
gmt >>timestamp
|
||||
{
|
||||
[ process-irc-trailing ]
|
||||
[ process-irc-prefix ]
|
||||
|
|
|
@ -71,4 +71,7 @@ IN: irc.messages.tests
|
|||
{ name "nickname" }
|
||||
{ trailing "Nickname is already in use" } } }
|
||||
[ ":ircserver.net 433 * nickname :Nickname is already in use"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :ACTION jumps!"
|
||||
string>irc-message action? ] unit-test
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators
|
||||
arrays classes.tuple math.order words assocs strings irc.messages.base ;
|
||||
arrays classes.tuple math.order words assocs strings irc.messages.base
|
||||
combinators.short-circuit math ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages
|
||||
|
||||
|
@ -61,8 +62,17 @@ IRC: rpl-names-end "366" nickname channel : comment ;
|
|||
IRC: rpl-nickname-in-use "433" _ name ;
|
||||
IRC: rpl-nick-collision "436" nickname : comment ;
|
||||
|
||||
PREDICATE: channel-mode < mode name>> first "#&" member? ;
|
||||
PREDICATE: participant-mode < channel-mode parameter>> ;
|
||||
PREDICATE: ctcp < privmsg
|
||||
trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ;
|
||||
PREDICATE: action < ctcp trailing>> rest "ACTION" head? ;
|
||||
|
||||
M: rpl-names post-process-irc-message ( rpl-names -- )
|
||||
[ [ blank? ] trim " " split ] change-nicks drop ;
|
||||
|
||||
PREDICATE: channel-mode < mode name>> first "#&" member? ;
|
||||
PREDICATE: participant-mode < channel-mode parameter>> ;
|
||||
M: ctcp post-process-irc-message ( ctcp -- )
|
||||
[ rest but-last ] change-text drop ;
|
||||
|
||||
M: action post-process-irc-message ( action -- )
|
||||
[ 7 tail ] change-text call-next-method ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry splitting ascii calendar accessors combinators
|
||||
USING: kernel fry splitting ascii accessors combinators
|
||||
arrays classes.tuple math.order words assocs
|
||||
irc.messages.base sequences ;
|
||||
IN: irc.messages.parser
|
||||
|
@ -32,4 +32,4 @@ PRIVATE>
|
|||
[ >>trailing ]
|
||||
tri*
|
||||
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
|
||||
now >>timestamp dup sender >>sender ;
|
||||
dup sender >>sender ;
|
||||
|
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel redis sequences ;
|
||||
IN: redis.assoc
|
||||
|
||||
INSTANCE: redis assoc
|
||||
|
||||
M: redis at* [ redis-get dup >boolean ] with-redis ;
|
||||
|
||||
M: redis assoc-size [ redis-dbsize ] with-redis ;
|
||||
|
||||
M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ;
|
||||
|
||||
M: redis set-at [ redis-set drop ] with-redis ;
|
||||
|
||||
M: redis delete-at [ redis-del drop ] with-redis ;
|
||||
|
||||
M: redis clear-assoc [ redis-flushdb drop ] with-redis ;
|
||||
|
||||
M: redis equal? assoc= ;
|
||||
|
||||
M: redis hashcode* assoc-hashcode ;
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
|
@ -0,0 +1 @@
|
|||
Assoc protocol implementation for Redis
|
|
@ -1,6 +1,8 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io redis.response-parser redis.command-writer ;
|
||||
USING: accessors io io.encodings.8-bit io.sockets
|
||||
io.streams.duplex kernel redis.command-writer
|
||||
redis.response-parser splitting ;
|
||||
IN: redis
|
||||
|
||||
#! Connection
|
||||
|
@ -23,7 +25,7 @@ IN: redis
|
|||
: redis-type ( key -- response ) type flush read-response ;
|
||||
|
||||
#! Key space
|
||||
: redis-keys ( pattern -- response ) keys flush read-response ;
|
||||
: redis-keys ( pattern -- response ) keys flush read-response " " split ;
|
||||
: redis-randomkey ( -- response ) randomkey flush read-response ;
|
||||
: redis-rename ( newkey key -- response ) rename flush read-response ;
|
||||
: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
|
||||
|
@ -72,3 +74,24 @@ IN: redis
|
|||
#! Remote server control
|
||||
: redis-info ( -- response ) info flush read-response ;
|
||||
: redis-monitor ( -- response ) monitor flush read-response ;
|
||||
|
||||
#! Redis object
|
||||
TUPLE: redis host port encoding password ;
|
||||
|
||||
CONSTANT: default-redis-port 6379
|
||||
|
||||
: <redis> ( -- redis )
|
||||
redis new
|
||||
"127.0.0.1" >>host
|
||||
default-redis-port >>port
|
||||
latin1 >>encoding ;
|
||||
|
||||
: redis-do-connect ( redis -- stream )
|
||||
[ host>> ] [ port>> ] [ encoding>> ] tri
|
||||
[ <inet> ] dip <client> drop ;
|
||||
|
||||
: with-redis ( redis quot -- )
|
||||
[
|
||||
[ redis-do-connect ] [ password>> ] bi
|
||||
[ swap [ [ redis-auth drop ] with-stream* ] keep ] when*
|
||||
] dip with-stream ; inline
|
||||
|
|
Loading…
Reference in New Issue