diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 3b1a5c6c85..1085feb0c6 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -30,10 +30,3 @@ words splitting grouping sorting ; \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test - -: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ; - -[ t ] [ - [ 10 quux ] ignore-errors - \ sort stack-trace-contains? -] unit-test diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index ab808d7914..1e659f1b99 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -219,7 +219,7 @@ M: number detect-number ; ! Regression USE: sorting -USE: sorting.private +USE: binary-search.private : old-binsearch ( elt quot seq -- elt quot i ) dup length 1 <= [ @@ -227,7 +227,7 @@ USE: sorting.private ] [ [ midpoint swap call ] 3keep roll dup zero? [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if + [ dup midpoint@ cut-slice old-binsearch ] if ] if ; inline [ 10 ] [ diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor new file mode 100644 index 0000000000..e9a5ad0ed8 --- /dev/null +++ b/extra/benchmark/backtrack/backtrack.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: backtrack shuffle math math.ranges quotations locals fry +kernel words io memoize macros io prettyprint sequences assocs +combinators namespaces ; +IN: benchmark.backtrack + +! This was suggested by Dr_Ford. Compute the number of quadruples +! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by +! placing them on the stack, and applying the operations +! +, -, * and rot as many times as we wish. + +: nop ; + +MACRO: amb-execute ( seq -- quot ) + [ length ] [ [ 1quotation ] assoc-map ] bi + '[ , amb , case ] ; + +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if + ] with-scope ; inline + +: do-something ( a b -- c ) + { + - * } amb-execute ; + +: some-rots ( a b c -- a b c ) + #! Try to rot 0, 1 or 2 times. + { nop rot -rot } amb-execute ; + +MEMO: 24-from-1 ( a -- ? ) + 24 = ; + +MEMO: 24-from-2 ( a b -- ? ) + [ do-something 24-from-1 ] [ 2drop ] if-amb ; + +MEMO: 24-from-3 ( a b c -- ? ) + [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ; + +MEMO: 24-from-4 ( a b c d -- ? ) + [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ; + +: find-impossible-24 ( -- n ) + 1 10 [a,b] [| a | + 1 10 [a,b] [| b | + 1 10 [a,b] [| c | + 1 10 [a,b] [| d | + a b c d 24-from-4 + ] count + ] sigma + ] sigma + ] sigma ; + +: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ; + +: backtrack-benchmark ( -- ) + words [ reset-memoized ] each + find-impossible-24 pprint "/10000 quadruples can make 24." print + words [ + dup pprint " tested " write "memoize" word-prop assoc-size pprint + " possibilities" print + ] each ; diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index df72572c67..3300faa125 100755 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -17,7 +17,7 @@ IN: channels.tests from ] unit-test -{ V{ 1 2 3 4 } } [ +{ { 1 2 3 4 } } [ V{ } clone [ from swap push ] in-thread [ from swap push ] in-thread @@ -30,7 +30,7 @@ IN: channels.tests natural-sort ] unit-test -{ V{ 1 2 4 9 } } [ +{ { 1 2 4 9 } } [ V{ } clone [ 4 swap to ] in-thread [ 2 swap to ] in-thread diff --git a/extra/farkup/authors.factor b/extra/farkup/authors.factor deleted file mode 100644 index 5674120196..0000000000 --- a/extra/farkup/authors.factor +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Slava Pestov diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt index 7c1b2f2279..5674120196 100644 --- a/extra/farkup/authors.txt +++ b/extra/farkup/authors.txt @@ -1 +1,2 @@ Doug Coleman +Slava Pestov diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor old mode 100755 new mode 100644 index 17d286252e..005e875d89 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -1,12 +1,19 @@ -USING: farkup kernel tools.test ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: farkup kernel peg peg.ebnf tools.test ; IN: farkup.tests -[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23" + "paragraph" \ farkup rule parse drop +] unit-test -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23\n" + "paragraph" \ farkup rule parse drop +] unit-test + +[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test [ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test [ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test [ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test @@ -15,11 +22,20 @@ IN: farkup.tests [ "

*

" ] [ "\\*" convert-farkup ] unit-test [ "

**

" ] [ "\\**" convert-farkup ] unit-test -[ "" ] [ "\n\n" convert-farkup ] unit-test -[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test -[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test -[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test -[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test +[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
    • \n
" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
    • \n
" ] [ "-foo\n-bar\n" convert-farkup ] unit-test + +[ "
  • foo
    • \n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test + + +[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test +[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test +[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test +[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test +[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test @@ -29,7 +45,7 @@ IN: farkup.tests [ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test -[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test [ "" ] [ "" convert-farkup ] unit-test @@ -77,8 +93,5 @@ IN: farkup.tests ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test [ - "

Feature comparison:\n\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" + "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test - -[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test -[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor old mode 100755 new mode 100644 index 321648136a..baf2ccaba2 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -1,72 +1,111 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io io.styles kernel memoize namespaces peg math -combinators sequences strings html.elements xml.entities -xmode.code2html splitting io.streams.string peg.parsers -sequences.deep unicode.categories ; +USING: accessors arrays combinators html.elements io io.streams.string +kernel math memoize namespaces peg peg.ebnf prettyprint +sequences sequences.deep strings xml.entities vectors splitting +xmode.code2html ; IN: farkup SYMBOL: relative-link-prefix SYMBOL: disable-images? SYMBOL: link-no-follow? - [[ drop "\n" ]] +2nl = nl nl -MEMO: text ( -- parser ) - [ delimiters member? not ] satisfy repeat1 - [ >string escape-string ] action ; +heading1 = "=" (!("=" | nl).)+ "=" + => [[ second >string heading1 boa ]] -MEMO: delimiter ( -- parser ) - [ dup delimiters member? swap "\r\n=" member? not and ] satisfy - [ 1string ] action ; +heading2 = "==" (!("=" | nl).)+ "==" + => [[ second >string heading2 boa ]] -: surround-with-foo ( string tag -- seq ) - dup swap swapd 3array ; +heading3 = "===" (!("=" | nl).)+ "===" + => [[ second >string heading3 boa ]] -: delimited ( str html -- parser ) - [ - over token hide , - text [ surround-with-foo ] swapd curry action , - token hide , - ] seq* ; +heading4 = "====" (!("=" | nl).)+ "====" + => [[ second >string heading4 boa ]] -MEMO: escaped-char ( -- parser ) - [ "\\" token hide , any-char , ] seq* [ >string ] action ; +strong = "*" (!("*" | nl).)+ "*" + => [[ second >string strong boa ]] -MEMO: strong ( -- parser ) "*" "strong" delimited ; -MEMO: emphasis ( -- parser ) "_" "em" delimited ; -MEMO: superscript ( -- parser ) "^" "sup" delimited ; -MEMO: subscript ( -- parser ) "~" "sub" delimited ; -MEMO: inline-code ( -- parser ) "%" "code" delimited ; -MEMO: nl ( -- parser ) - "\r\n" token [ drop "\n" ] action - "\r" token [ drop "\n" ] action - "\n" token 3choice ; -MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ; -MEMO: h1 ( -- parser ) "=" "h1" delimited ; -MEMO: h2 ( -- parser ) "==" "h2" delimited ; -MEMO: h3 ( -- parser ) "===" "h3" delimited ; -MEMO: h4 ( -- parser ) "====" "h4" delimited ; +emphasis = "_" (!("_" | nl).)+ "_" + => [[ second >string emphasis boa ]] + +superscript = "^" (!("^" | nl).)+ "^" + => [[ second >string superscript boa ]] + +subscript = "~" (!("~" | nl).)+ "~" + => [[ second >string subscript boa ]] + +inline-code = "%" (!("%" | nl).)+ "%" + => [[ second >string inline-code boa ]] + +escaped-char = "\" . => [[ second ]] + +image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]" + => [[ [ second >string ] [ fourth >string ] bi image boa ]] + | "[[image:" (!("]").)+ "]]" + => [[ second >string f image boa ]] + +simple-link = "[[" (!("|]" | "]]") .)+ "]]" + => [[ second >string dup link boa ]] + +labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]" + => [[ [ second >string ] [ fourth >string ] bi link boa ]] + +link = image-link | labelled-link | simple-link + +heading = heading4 | heading3 | heading2 | heading1 + +inline-tag = strong | emphasis | superscript | subscript | inline-code + | link | escaped-char + +inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' + +table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|' + => [[ first ]] +table-row = "|" (table-column)+ + => [[ second table-row boa ]] +table = ((table-row nl => [[ first ]] )+ table-row? | table-row) + => [[ table boa ]] + +paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+ +paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] + | (paragraph-item nl)+ paragraph-item? + | paragraph-item) + => [[ paragraph boa ]] + +list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* + => [[ second list-item boa ]] +list = ((list-item nl)+ list-item? | list-item) + => [[ list boa ]] + +code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]" + => [[ [ second >string ] [ fourth >string ] bi code boa ]] + +stand-alone = (code | heading | list | table | paragraph | nl)* +;EBNF -MEMO: eq ( -- parser ) - [ - h1 ensure-not , - h2 ensure-not , - h3 ensure-not , - h4 ensure-not , - "=" token , - ] seq* ; -: render-code ( string mode -- string' ) - >r string-lines r> - [ - 
-            htmlize-lines
-
- ] with-string-writer ; : invalid-url "javascript:alert('Invalid URL in farkup');" ; @@ -85,116 +124,57 @@ MEMO: eq ( -- parser ) : escape-link ( href text -- href-esc text-esc ) >r check-url escape-quoted-string r> escape-string ; -: make-link ( href text -- seq ) +: write-link ( text href -- ) escape-link - [ - "r , r> "\"" , - link-no-follow? get [ " nofollow=\"true\"" , ] when - ">" , , "" , - ] { } make ; + "" write write "" write ; -: make-image-link ( href alt -- seq ) +: write-image-link ( href text -- ) disable-images? get [ - 2drop "Images are not allowed" + 2drop "Images are not allowed" write ] [ escape-link - [ - "\""" , - ] { } make + >r " + dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if + "/>" write ] if ; -MEMO: image-link ( -- parser ) +: render-code ( string mode -- string' ) + >r string-lines r> [ - "[[image:" token hide , - [ "|]" member? not ] satisfy repeat1 [ >string ] action , - "|" token hide - [ CHAR: ] = not ] satisfy repeat0 2seq - [ first >string ] action optional , - "]]" token hide , - ] seq* [ first2 make-image-link ] action ; + 
+            htmlize-lines
+
+ ] with-string-writer write ; -MEMO: simple-link ( -- parser ) - [ - "[[" token hide , - [ "|]" member? not ] satisfy repeat1 , - "]]" token hide , - ] seq* [ first dup make-link ] action ; - -MEMO: labelled-link ( -- parser ) - [ - "[[" token hide , - [ CHAR: | = not ] satisfy repeat1 , - "|" token hide , - [ CHAR: ] = not ] satisfy repeat1 , - "]]" token hide , - ] seq* [ first2 make-link ] action ; - -MEMO: link ( -- parser ) - [ image-link , simple-link , labelled-link , ] choice* ; - -DEFER: line -MEMO: list-item ( -- parser ) - [ - "-" token hide , ! text , - [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action , - ] seq* [ "li" surround-with-foo ] action ; - -MEMO: list ( -- parser ) - list-item nl hide list-of - [ "ul" surround-with-foo ] action ; - -MEMO: table-column ( -- parser ) - text [ "td" surround-with-foo ] action ; - -MEMO: table-row ( -- parser ) - "|" token hide - table-column "|" token hide list-of - "|" token hide nl hide optional 4seq - [ "tr" surround-with-foo ] action ; - -MEMO: table ( -- parser ) - table-row repeat1 - [ "table" surround-with-foo ] action ; - -MEMO: code ( -- parser ) - [ - "[" token hide , - [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action , - "{" token hide , - "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action , - "}]" token hide , - ] seq* [ first2 swap render-code ] action ; - -MEMO: line ( -- parser ) - [ - nl table 2seq , - nl list 2seq , - text , strong , emphasis , link , - superscript , subscript , inline-code , - escaped-char , delimiter , eq , - ] choice* repeat1 ; - -MEMO: paragraph ( -- parser ) - line - nl over 2seq repeat0 - nl nl ensure-not 2seq optional 3seq - [ - dup [ dup string? not swap [ blank? ] all? or ] deep-all? - [ "

" swap "

" 3array ] unless - ] action ; - -PRIVATE> - -PEG: parse-farkup ( -- parser ) - [ - list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , - ] choice* repeat0 nl optional 2seq ; - -: write-farkup ( parse-result -- ) - [ dup string? [ write ] [ drop ] if ] deep-each ; +GENERIC: write-farkup ( obj -- ) +: ( string -- ) write ; +: ( string -- ) write ; +: in-tag. ( obj quot string -- ) [ call ] keep ; inline +M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ; +M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ; +M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ; +M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ; +M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ; +M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ; +M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ; +M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ; +M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ; +M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ; +M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ; +M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ; +M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ; +M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; +M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; +M: table-row write-farkup ( obj -- ) + obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ; +M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ; +M: fixnum write-farkup ( obj -- ) write1 ; +M: string write-farkup ( obj -- ) write ; +M: vector write-farkup ( obj -- ) [ write-farkup ] each ; +M: f write-farkup ( obj -- ) drop ; : convert-farkup ( string -- string' ) - parse-farkup [ write-farkup ] with-string-writer ; + farkup [ write-farkup ] with-string-writer ; diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 5779371078..56c7118ab9 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test -[ "
  • foo
  • bar
" ] [ +[ "
  • foo
    • \n
  • bar
" ] [ [ "farkup" T{ farkup } render ] with-string-writer ] unit-test diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 472805f5ae..2dbbe8b8f5 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays qualified fry - continuations threads strings classes combinators - irc.messages irc.messages.private ; + continuations threads strings classes combinators splitting hashtables + ascii irc.messages irc.messages.private ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -27,7 +27,7 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages TUPLE: irc-listener in-messages out-messages ; TUPLE: irc-server-listener < irc-listener ; -TUPLE: irc-channel-listener < irc-listener name password timeout ; +TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ @@ -37,10 +37,10 @@ SYMBOL: +server-listener+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; : ( name -- irc-nick-listener ) - rot irc-nick-listener boa ; + [ ] dip irc-nick-listener boa ; ! ====================================== ! Message objects @@ -52,8 +52,8 @@ SINGLETON: irc-connected ! sent when connection is established UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ in-messages>> irc-end swap mailbox-put ] - [ f >>is-running drop ] + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] [ stream>> dispose ] tri ; @@ -74,18 +74,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; listener> [ +server-listener+ listener> ] unless* [ in-messages>> mailbox-put ] [ drop ] if* ; +: remove-participant ( nick channel -- ) + listener> [ participants>> delete-at ] [ drop ] if* ; + +: remove-participant-from-all ( nick -- ) + irc> listeners>> + [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with + assoc-each ; + +: add-participant ( nick mode channel -- ) + listener> [ participants>> set-at ] [ 2drop ] if* ; + +DEFER: me? + +: maybe-forward-join ( join -- ) + [ prefix>> parse-name me? ] keep and + [ irc> join-messages>> mailbox-put ] when* ; + ! ====================================== ! IRC client messages ! ====================================== -GENERIC: irc-message>string ( irc-message -- string ) - -M: irc-message irc-message>string ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] - tri 3array " " sjoin ; - : /NICK ( nick -- ) "NICK " irc-write irc-print ; @@ -99,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string ) : /JOIN ( channel password -- ) "JOIN " irc-write - [ " :" swap 3append ] when* irc-print ; + [ [ " :" ] dip 3append ] when* irc-print ; : /PART ( channel text -- ) [ "PART " irc-write irc-write ] dip @@ -153,17 +162,34 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - [ [ prefix>> parse-name me? ] keep and - [ irc> join-messages>> mailbox-put ] when* ] + [ maybe-forward-join ] [ dup trailing>> to-listener ] - bi ; + [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + tri ; M: part handle-incoming-irc ( part -- ) - dup channel>> to-listener ; + [ dup channel>> to-listener ] keep + [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; M: kick handle-incoming-irc ( kick -- ) - [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when - to-listener ; + [ dup channel>> to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + tri ; + +M: quit handle-incoming-irc ( quit -- ) + [ prefix>> parse-name remove-participant-from-all ] keep + call-next-method ; + +: >nick/mode ( string -- nick mode ) + dup first "+@" member? [ unclip ] [ f ] if ; + +: names-reply>participants ( names-reply -- participants ) + trailing>> [ blank? ] trim " " split + [ >nick/mode 2array ] map >hashtable ; + +M: names-reply handle-incoming-irc ( names-reply -- ) + [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -180,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- ) M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; -M: part handle-outgoing-irc ( privmsg -- ) +M: part handle-outgoing-irc ( part -- ) [ channel>> ] [ trailing>> "" or ] bi /PART ; ! ====================================== @@ -188,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- ) ! ====================================== : irc-mailbox-get ( mailbox quot -- ) - swap 5 seconds - '[ , , , mailbox-get-timeout swap call ] + [ 5 seconds ] dip + '[ , , , [ mailbox-get-timeout ] dip call ] [ drop ] recover ; inline : handle-reader-message ( irc-message -- ) @@ -199,11 +225,12 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ in-messages>> irc-disconnected swap mailbox-put ] + [ [ irc-disconnected ] dip in-messages>> mailbox-put ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; +! FIXME: do something with the exception, store somewhere to help debugging : handle-disconnect ( error -- ) drop irc> is-running>> [ (handle-disconnect) ] when ; @@ -236,6 +263,7 @@ DEFER: (connect-irc) { { [ dup string? ] [ strings>privmsg ] } { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; : listener-loop ( name listener -- ) @@ -275,7 +303,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) [ name>> ] keep set+run-listener ; M: irc-server-listener (add-listener) ( irc-server-listener -- ) - +server-listener+ swap set+run-listener ; + [ +server-listener+ ] dip set+run-listener ; GENERIC: (remove-listener) ( irc-listener -- ) @@ -283,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) name>> unregister-listener ; M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) - [ [ out-messages>> ] [ name>> ] bi - \ part new swap >>channel mailbox-put ] keep + [ [ name>> ] [ out-messages>> ] bi + [ [ part new ] dip >>channel ] dip mailbox-put ] keep name>> unregister-listener ; M: irc-server-listener (remove-listener) ( irc-server-listener -- ) @@ -294,10 +322,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep swap >>stream t >>is-running - in-messages>> irc-connected swap mailbox-put ; + in-messages>> [ irc-connected ] dip mailbox-put ; : with-irc-client ( irc-client quot -- ) - >r current-irc-client r> with-variable ; inline + [ current-irc-client ] dip with-variable ; inline PRIVATE> diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index f1beba9b26..205630d790 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,13 +1,15 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: kernel fry sequences splitting ascii calendar accessors combinators - classes.tuple math.order ; +USING: kernel fry splitting ascii calendar accessors combinators qualified + arrays classes.tuple math.order ; +RENAME: join sequences => sjoin +EXCLUDE: sequences => join ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: logged-in < irc-message name ; TUPLE: ping < irc-message ; -TUPLE: join < irc-message channel ; +TUPLE: join < irc-message ; TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; TUPLE: privmsg < irc-message name ; @@ -16,8 +18,21 @@ TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name channel mode ; +TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +GENERIC: irc-message>client-line ( irc-message -- string ) + +M: irc-message irc-message>client-line ( irc-message -- string ) + [ command>> ] + [ parameters>> " " sjoin ] + [ trailing>> dup [ CHAR: : prefix ] when ] + tri 3array " " sjoin ; + +GENERIC: irc-message>server-line ( irc-message -- string ) +M: irc-message irc-message>server-line ( irc-message -- string ) + drop "not implemented yet" ; + > nickname>> print-irc ] + [ listener get write-message ] bi ; + +: quote ( string -- ) + drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ircui-rc b/extra/irc/ui/ircui-rc new file mode 100755 index 0000000000..a1533c7b4d --- /dev/null +++ b/extra/irc/ui/ircui-rc @@ -0,0 +1,9 @@ +! Default system ircui-rc file +! Copy into .ircui-rc in your home directory and then change username and such +! To find your home directory, type "home ." into a Factor listener + +USING: irc.client irc.ui ; + +"irc.freenode.org" 8001 "factor-irc" f ! server port nick password +{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin +server-open diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor new file mode 100755 index 0000000000..6655f310e7 --- /dev/null +++ b/extra/irc/ui/load/load.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel io.files parser editors sequences ; + +IN: irc.ui.load + +: file-or ( path path -- path ) over exists? ? ; + +: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ; + +: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ; + +: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ; + +: run-ircui ( -- ) ircui-rc run-file ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index cc138dad92..12f9d01183 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -3,12 +3,17 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables - ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers - ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs - io io.styles namespaces irc.client irc.messages ; + ui ui.gadgets ui.gadgets.panes ui.gadgets.editors + ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures + ui.gadgets.tabs ui.gadgets.grids + io io.styles namespaces calendar calendar.format + irc.client irc.client.private irc.messages irc.messages.private + irc.ui.commandparser irc.ui.load ; IN: irc.ui +SYMBOL: listener + SYMBOL: client TUPLE: ui-window client tabs ; @@ -19,36 +24,45 @@ TUPLE: ui-window client tabs ; : green { 0 0.5 0 1 } ; : blue { 0 0 1 1 } ; -: prefix>nick ( prefix -- nick ) - "!" split first ; +: dot-or-parens ( string -- string ) + dup empty? [ drop "." ] + [ "(" prepend ")" append ] if ; GENERIC: write-irc ( irc-message -- ) M: privmsg write-irc "<" blue write-color - [ prefix>> prefix>nick write ] keep - ">" blue write-color - " " write + [ prefix>> parse-name write ] keep + "> " blue write-color trailing>> write ; +TUPLE: own-message message nick timestamp ; + +: ( message nick -- own-message ) + now own-message boa ; + +M: own-message write-irc + "<" blue write-color + [ nick>> bold font-style associate format ] keep + "> " blue write-color + message>> write ; + M: join write-irc "* " green write-color - prefix>> prefix>nick write + prefix>> parse-name write " has entered the channel." green write-color ; M: part write-irc "* " red write-color - [ prefix>> prefix>nick write ] keep - " has left the channel(" red write-color - trailing>> write - ")" red write-color ; + [ prefix>> parse-name write ] keep + " has left the channel" red write-color + trailing>> dot-or-parens red write-color ; M: quit write-irc "* " red write-color - [ prefix>> prefix>nick write ] keep - " has left IRC(" red write-color - trailing>> write - ")" red write-color ; + [ prefix>> parse-name write ] keep + " has left IRC" red write-color + trailing>> dot-or-parens red write-color ; M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -63,15 +77,12 @@ M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE : print-irc ( irc-message -- ) - write-irc nl ; + [ timestamp>> timestamp>hms write " " write ] + [ write-irc nl ] bi ; -: send-message ( message listener client -- ) - "<" blue write-color - profile>> nickname>> bold font-style associate format - ">" blue write-color - " " write - over write nl - out-messages>> mailbox-put ; +: send-message ( message -- ) + [ print-irc ] + [ listener get write-message ] bi ; : display ( stream listener -- ) '[ , [ [ t ] @@ -84,35 +95,44 @@ M: irc-message write-irc TUPLE: irc-editor < editor outstream listener client ; -: ( pane listener client -- editor ) - [ irc-editor new-editor +: ( page pane listener -- client editor ) + irc-editor new-editor swap >>listener swap >>outstream - ] dip client>> >>client ; + over client>> >>client ; : editor-send ( irc-editor -- ) { [ outstream>> ] - [ editor-string ] [ listener>> ] [ client>> ] + [ editor-string ] [ "" swap set-editor-string ] } cleave - '[ , , , send-message ] with-output-stream ; + '[ , listener set , client set , parse-message ] with-output-stream ; irc-editor "general" f { { T{ key-down f f "RET" } editor-send } { T{ key-down f f "ENTER" } editor-send } } define-command-map -: irc-page ( name pane editor tabbed -- ) - [ [ @bottom frame, ! editor - @center frame, ! pane - ] make-frame swap ] dip add-page ; +TUPLE: irc-page < frame listener client ; + +: ( listener client -- irc-page ) + irc-page new-frame + swap client>> >>client swap [ >>listener ] keep + [ [ @center grid-add* ] keep ] + [ @bottom grid-add* ] bi ; + +M: irc-page graft* + [ listener>> ] [ client>> ] bi + add-listener ; + +M: irc-page ungraft* + [ listener>> ] [ client>> ] bi + remove-listener ; : join-channel ( name ui-window -- ) [ dup ] dip - [ client>> add-listener ] - [ drop dup ] - [ [ ] keep ] 2tri - tabs>> irc-page ; + [ swap ] keep + tabs>> add-page ; : irc-window ( ui-window -- ) [ tabs>> ] @@ -125,6 +145,10 @@ irc-editor "general" f { [ listeners>> +server-listener+ swap at "Server" associate >>tabs ] bi ; -: freenode-connect ( -- ui-window ) - "irc.freenode.org" 8001 "factor-irc" f - ui-connect [ irc-window ] keep ; +: server-open ( server port nick password channels -- ) + [ ui-connect [ irc-window ] keep ] dip + [ over join-channel ] each ; + +: main-run ( -- ) run-ircui ; + +MAIN: main-run diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor index d5baf4914c..991551c009 100644 --- a/extra/multi-methods/tests/canonicalize.factor +++ b/extra/multi-methods/tests/canonicalize.factor @@ -49,7 +49,7 @@ kernel strings ; { { object ppc object } "b" } { { string object windows } "c" } } - V{ cpu os } + { cpu os } ] [ example-1 canonicalize-specializers ] unit-test diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 7f14293a15..45e1e9b218 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -449,7 +449,7 @@ foo= 'd' ] unit-test [ - "USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop + "USING: peg.ebnf ; " eval drop ] must-fail { t } [ @@ -519,4 +519,4 @@ Tok = Spaces (Number | Special ) { "\\" } [ "\\" [EBNF foo="\\" EBNF] -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 2a75fcccc0..cc94a215e6 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser ) M: ebnf-rule (transform) ( ast -- parser ) dup elements>> (transform) [ - swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ + swap symbol>> dup get parser? [ "Rule '" over append "' defined more than once" append throw ] [ set