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

db4
Eduardo Cavazos 2008-07-16 14:47:50 -05:00
commit 3ba671aee8
19 changed files with 436 additions and 263 deletions

View File

@ -30,10 +30,3 @@ words splitting grouping sorting ;
\ + stack-trace-contains? \ + stack-trace-contains?
\ > stack-trace-contains? \ > stack-trace-contains?
] unit-test ] unit-test
: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
[ t ] [
[ 10 quux ] ignore-errors
\ sort stack-trace-contains?
] unit-test

View File

@ -219,7 +219,7 @@ M: number detect-number ;
! Regression ! Regression
USE: sorting USE: sorting
USE: sorting.private USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i ) : old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [ dup length 1 <= [
@ -227,7 +227,7 @@ USE: sorting.private
] [ ] [
[ midpoint swap call ] 3keep roll dup zero? [ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ] [ drop dup slice-from swap midpoint@ + ]
[ partition old-binsearch ] if [ dup midpoint@ cut-slice old-binsearch ] if
] if ; inline ] if ; inline
[ 10 ] [ [ 10 ] [

View File

@ -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 ] [ <enum> [ 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 ;

View File

@ -17,7 +17,7 @@ IN: channels.tests
from from
] unit-test ] unit-test
{ V{ 1 2 3 4 } } [ { { 1 2 3 4 } } [
V{ } clone <channel> V{ } clone <channel>
[ from swap push ] in-thread [ from swap push ] in-thread
[ from swap push ] in-thread [ from swap push ] in-thread
@ -30,7 +30,7 @@ IN: channels.tests
natural-sort natural-sort
] unit-test ] unit-test
{ V{ 1 2 4 9 } } [ { { 1 2 4 9 } } [
V{ } clone <channel> V{ } clone <channel>
[ 4 swap to ] in-thread [ 4 swap to ] in-thread
[ 2 swap to ] in-thread [ 2 swap to ] in-thread

View File

@ -1,2 +0,0 @@
Doug Coleman
Slava Pestov

View File

@ -1 +1,2 @@
Doug Coleman Doug Coleman
Slava Pestov

45
extra/farkup/farkup-tests.factor Executable file → Normal file
View File

@ -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 IN: farkup.tests
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test [ ] [
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test "abcd-*strong*\nasdifj\nweouh23ouh23"
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test "paragraph" \ farkup rule parse drop
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test ] unit-test
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test [ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23\n"
"paragraph" \ farkup rule parse drop
] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test [ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test [ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test [ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
@ -15,11 +22,20 @@ IN: farkup.tests
[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test [ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test [ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
[ "" ] [ "\n\n" convert-farkup ] unit-test [ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test [ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test [ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test [ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test [ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-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
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test [ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test [ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test [ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
@ -29,7 +45,7 @@ IN: farkup.tests
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test [ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test [ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "" ] [ "" 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|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
[ [
"<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>" "<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
] [ "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 ] [ "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
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test

288
extra/farkup/farkup.factor Executable file → Normal file
View File

@ -1,72 +1,111 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.styles kernel memoize namespaces peg math USING: accessors arrays combinators html.elements io io.streams.string
combinators sequences strings html.elements xml.entities kernel math memoize namespaces peg peg.ebnf prettyprint
xmode.code2html splitting io.streams.string peg.parsers sequences sequences.deep strings xml.entities vectors splitting
sequences.deep unicode.categories ; xmode.code2html ;
IN: farkup IN: farkup
SYMBOL: relative-link-prefix SYMBOL: relative-link-prefix
SYMBOL: disable-images? SYMBOL: disable-images?
SYMBOL: link-no-follow? SYMBOL: link-no-follow?
<PRIVATE TUPLE: heading1 obj ;
TUPLE: heading2 obj ;
TUPLE: heading3 obj ;
TUPLE: heading4 obj ;
TUPLE: strong obj ;
TUPLE: emphasis obj ;
TUPLE: superscript obj ;
TUPLE: subscript obj ;
TUPLE: inline-code obj ;
TUPLE: paragraph obj ;
TUPLE: list-item obj ;
TUPLE: list obj ;
TUPLE: table obj ;
TUPLE: table-row obj ;
TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
: delimiters ( -- string ) EBNF: farkup
"*_^~%[-=|\\\r\n" ; inline nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
MEMO: text ( -- parser ) heading1 = "=" (!("=" | nl).)+ "="
[ delimiters member? not ] satisfy repeat1 => [[ second >string heading1 boa ]]
[ >string escape-string ] action ;
MEMO: delimiter ( -- parser ) heading2 = "==" (!("=" | nl).)+ "=="
[ dup delimiters member? swap "\r\n=" member? not and ] satisfy => [[ second >string heading2 boa ]]
[ 1string ] action ;
: surround-with-foo ( string tag -- seq ) heading3 = "===" (!("=" | nl).)+ "==="
dup <foo> swap </foo> swapd 3array ; => [[ second >string heading3 boa ]]
: delimited ( str html -- parser ) heading4 = "====" (!("=" | nl).)+ "===="
[ => [[ second >string heading4 boa ]]
over token hide ,
text [ surround-with-foo ] swapd curry action ,
token hide ,
] seq* ;
MEMO: escaped-char ( -- parser ) strong = "*" (!("*" | nl).)+ "*"
[ "\\" token hide , any-char , ] seq* [ >string ] action ; => [[ second >string strong boa ]]
MEMO: strong ( -- parser ) "*" "strong" delimited ; emphasis = "_" (!("_" | nl).)+ "_"
MEMO: emphasis ( -- parser ) "_" "em" delimited ; => [[ second >string emphasis boa ]]
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
MEMO: subscript ( -- parser ) "~" "sub" delimited ; superscript = "^" (!("^" | nl).)+ "^"
MEMO: inline-code ( -- parser ) "%" "code" delimited ; => [[ second >string superscript boa ]]
MEMO: nl ( -- parser )
"\r\n" token [ drop "\n" ] action subscript = "~" (!("~" | nl).)+ "~"
"\r" token [ drop "\n" ] action => [[ second >string subscript boa ]]
"\n" token 3choice ;
MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ; inline-code = "%" (!("%" | nl).)+ "%"
MEMO: h1 ( -- parser ) "=" "h1" delimited ; => [[ second >string inline-code boa ]]
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
MEMO: h3 ( -- parser ) "===" "h3" delimited ; escaped-char = "\" . => [[ second ]]
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
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>
[
<pre>
htmlize-lines
</pre>
] with-string-writer ;
: invalid-url "javascript:alert('Invalid URL in farkup');" ; : invalid-url "javascript:alert('Invalid URL in farkup');" ;
@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
: escape-link ( href text -- href-esc text-esc ) : escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ; >r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq ) : write-link ( text href -- )
escape-link escape-link
[ "<a" write
"<a" , " href=\"" write write "\"" write
" href=\"" , >r , r> "\"" , link-no-follow? get [ " nofollow=\"true\"" write ] when
link-no-follow? get [ " nofollow=\"true\"" , ] when ">" write write "</a>" write ;
">" , , "</a>" ,
] { } make ;
: make-image-link ( href alt -- seq ) : write-image-link ( href text -- )
disable-images? get [ disable-images? get [
2drop "<strong>Images are not allowed</strong>" 2drop "<strong>Images are not allowed</strong>" write
] [ ] [
escape-link escape-link
[ >r "<img src=\"" write write "\"" write r>
"<img src=\"" , swap , "\"" , dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if "/>" write
"/>" ,
] { } make
] if ; ] if ;
MEMO: image-link ( -- parser ) : render-code ( string mode -- string' )
>r string-lines r>
[ [
"[[image:" token hide , <pre>
[ "|]" member? not ] satisfy repeat1 [ >string ] action , htmlize-lines
"|" token hide </pre>
[ CHAR: ] = not ] satisfy repeat0 2seq ] with-string-writer write ;
[ first >string ] action optional ,
"]]" token hide ,
] seq* [ first2 make-image-link ] action ;
MEMO: simple-link ( -- parser ) GENERIC: write-farkup ( obj -- )
[ : <foo.> ( string -- ) <foo> write ;
"[[" token hide , : </foo.> ( string -- ) </foo> write ;
[ "|]" member? not ] satisfy repeat1 , : in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
"]]" token hide , M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
] seq* [ first dup make-link ] action ; M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
MEMO: labelled-link ( -- parser ) M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
[ M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
"[[" token hide , M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
[ CHAR: | = not ] satisfy repeat1 , M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
"|" token hide , M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
[ CHAR: ] = not ] satisfy repeat1 , M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
"]]" token hide , M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
] seq* [ first2 make-link ] action ; M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
MEMO: link ( -- parser ) M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
[ image-link , simple-link , labelled-link , ] choice* ; M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
DEFER: line M: table-row write-farkup ( obj -- )
MEMO: list-item ( -- parser ) obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
[ M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
"-" token hide , ! text , M: fixnum write-farkup ( obj -- ) write1 ;
[ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action , M: string write-farkup ( obj -- ) write ;
] seq* [ "li" surround-with-foo ] action ; M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
M: f write-farkup ( obj -- ) drop ;
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?
[ "<p>" swap "</p>" 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 ;
: convert-farkup ( string -- string' ) : convert-farkup ( string -- string' )
parse-farkup [ write-farkup ] with-string-writer ; farkup [ write-farkup ] with-string-writer ;

View File

@ -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\n-bar" "farkup" set-value ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ [ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
[ "farkup" T{ farkup } render ] with-string-writer [ "farkup" T{ farkup } render ] with-string-writer
] unit-test ] unit-test

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays qualified fry accessors destructors namespaces io assocs arrays qualified fry
continuations threads strings classes combinators continuations threads strings classes combinators splitting hashtables
irc.messages irc.messages.private ; ascii irc.messages irc.messages.private ;
RENAME: join sequences => sjoin RENAME: join sequences => sjoin
EXCLUDE: sequences => join ; EXCLUDE: sequences => join ;
IN: irc.client 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-listener in-messages out-messages ;
TUPLE: irc-server-listener < irc-listener ; 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 ; TUPLE: irc-nick-listener < irc-listener name ;
SYMBOL: +server-listener+ SYMBOL: +server-listener+
@ -37,10 +37,10 @@ SYMBOL: +server-listener+
<mailbox> <mailbox> irc-server-listener boa ; <mailbox> <mailbox> irc-server-listener boa ;
: <irc-channel-listener> ( name -- irc-channel-listener ) : <irc-channel-listener> ( name -- irc-channel-listener )
<mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ; [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
: <irc-nick-listener> ( name -- irc-nick-listener ) : <irc-nick-listener> ( name -- irc-nick-listener )
<mailbox> <mailbox> rot irc-nick-listener boa ; [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
! ====================================== ! ======================================
! Message objects ! Message objects
@ -52,8 +52,8 @@ SINGLETON: irc-connected ! sent when connection is established
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: terminate-irc ( irc-client -- ) : terminate-irc ( irc-client -- )
[ in-messages>> irc-end swap mailbox-put ] [ [ irc-end ] dip in-messages>> mailbox-put ]
[ f >>is-running drop ] [ [ f ] dip (>>is-running) ]
[ stream>> dispose ] [ stream>> dispose ]
tri ; tri ;
@ -74,18 +74,27 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
listener> [ +server-listener+ listener> ] unless* listener> [ +server-listener+ listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ; [ 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 ! 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 ( nick -- )
"NICK " irc-write irc-print ; "NICK " irc-write irc-print ;
@ -99,7 +108,7 @@ M: irc-message irc-message>string ( irc-message -- string )
: /JOIN ( channel password -- ) : /JOIN ( channel password -- )
"JOIN " irc-write "JOIN " irc-write
[ " :" swap 3append ] when* irc-print ; [ [ " :" ] dip 3append ] when* irc-print ;
: /PART ( channel text -- ) : /PART ( channel text -- )
[ "PART " irc-write irc-write ] dip [ "PART " irc-write irc-write ] dip
@ -153,17 +162,34 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ; dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- ) M: join handle-incoming-irc ( join -- )
[ [ prefix>> parse-name me? ] keep and [ maybe-forward-join ]
[ irc> join-messages>> mailbox-put ] when* ]
[ dup trailing>> to-listener ] [ dup trailing>> to-listener ]
bi ; [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
tri ;
M: part handle-incoming-irc ( part -- ) 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 -- ) M: kick handle-incoming-irc ( kick -- )
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when [ dup channel>> to-listener ]
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 -- ) M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ; broadcast-message-to-listeners ;
@ -180,7 +206,7 @@ GENERIC: handle-outgoing-irc ( obj -- )
M: privmsg handle-outgoing-irc ( privmsg -- ) M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ; [ name>> ] [ trailing>> ] bi /PRIVMSG ;
M: part handle-outgoing-irc ( privmsg -- ) M: part handle-outgoing-irc ( part -- )
[ channel>> ] [ trailing>> "" or ] bi /PART ; [ channel>> ] [ trailing>> "" or ] bi /PART ;
! ====================================== ! ======================================
@ -188,8 +214,8 @@ M: part handle-outgoing-irc ( privmsg -- )
! ====================================== ! ======================================
: irc-mailbox-get ( mailbox quot -- ) : irc-mailbox-get ( mailbox quot -- )
swap 5 seconds [ 5 seconds ] dip
'[ , , , mailbox-get-timeout swap call ] '[ , , , [ mailbox-get-timeout ] dip call ]
[ drop ] recover ; inline [ drop ] recover ; inline
: handle-reader-message ( irc-message -- ) : handle-reader-message ( irc-message -- )
@ -199,11 +225,12 @@ DEFER: (connect-irc)
: (handle-disconnect) ( -- ) : (handle-disconnect) ( -- )
irc> irc>
[ in-messages>> irc-disconnected swap mailbox-put ] [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ] [ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ] [ profile>> nickname>> /LOGIN ]
tri ; tri ;
! FIXME: do something with the exception, store somewhere to help debugging
: handle-disconnect ( error -- ) : handle-disconnect ( error -- )
drop irc> is-running>> [ (handle-disconnect) ] when ; drop irc> is-running>> [ (handle-disconnect) ] when ;
@ -236,6 +263,7 @@ DEFER: (connect-irc)
{ {
{ [ dup string? ] [ strings>privmsg ] } { [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] } { [ dup privmsg instance? ] [ swap >>name ] }
[ nip ]
} cond ; } cond ;
: listener-loop ( name listener -- ) : listener-loop ( name listener -- )
@ -275,7 +303,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
[ name>> ] keep set+run-listener ; [ name>> ] keep set+run-listener ;
M: irc-server-listener (add-listener) ( irc-server-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 -- ) GENERIC: (remove-listener) ( irc-listener -- )
@ -283,8 +311,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
name>> unregister-listener ; name>> unregister-listener ;
M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
[ [ out-messages>> ] [ name>> ] bi [ [ name>> ] [ out-messages>> ] bi
\ part new swap >>channel mailbox-put ] keep [ [ part new ] dip >>channel ] dip mailbox-put ] keep
name>> unregister-listener ; name>> unregister-listener ;
M: irc-server-listener (remove-listener) ( irc-server-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 [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
swap >>stream swap >>stream
t >>is-running t >>is-running
in-messages>> irc-connected swap mailbox-put ; in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot -- ) : with-irc-client ( irc-client quot -- )
>r current-irc-client r> with-variable ; inline [ current-irc-client ] dip with-variable ; inline
PRIVATE> PRIVATE>

View File

@ -1,13 +1,15 @@
! Copyright (C) 2008 Bruno Deferrari ! Copyright (C) 2008 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry sequences splitting ascii calendar accessors combinators USING: kernel fry splitting ascii calendar accessors combinators qualified
classes.tuple math.order ; arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.messages IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ; TUPLE: logged-in < irc-message name ;
TUPLE: ping < irc-message ; TUPLE: ping < irc-message ;
TUPLE: join < irc-message channel ; TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ; TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ; TUPLE: quit < irc-message ;
TUPLE: privmsg < irc-message name ; TUPLE: privmsg < irc-message name ;
@ -16,8 +18,21 @@ TUPLE: roomlist < irc-message channel names ;
TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: nick-in-use < irc-message asterisk name ;
TUPLE: notice < irc-message type ; TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name channel mode ; TUPLE: mode < irc-message name channel mode ;
TUPLE: names-reply < irc-message who = channel ;
TUPLE: unhandled < irc-message ; 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" ;
<PRIVATE <PRIVATE
! ====================================== ! ======================================
! Message parsing ! Message parsing
@ -55,6 +70,7 @@ TUPLE: unhandled < irc-message ;
{ "NOTICE" [ \ notice ] } { "NOTICE" [ \ notice ] }
{ "001" [ \ logged-in ] } { "001" [ \ logged-in ] }
{ "433" [ \ nick-in-use ] } { "433" [ \ nick-in-use ] }
{ "353" [ \ names-reply ] }
{ "JOIN" [ \ join ] } { "JOIN" [ \ join ] }
{ "PART" [ \ part ] } { "PART" [ \ part ] }
{ "PRIVMSG" [ \ privmsg ] } { "PRIVMSG" [ \ privmsg ] }

View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
IN: irc.ui.commandparser
"irc.ui.commands" require
: command ( string string -- string command )
dup empty? [ drop "say" ] when
dup "irc.ui.commands" lookup
[ nip ]
[ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
: parse-message ( string -- )
"/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;

View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
IN: irc.ui.commands
: say ( string -- )
[ client get profile>> nickname>> <own-message> print-irc ]
[ listener get write-message ] bi ;
: quote ( string -- )
drop ; ! THIS WILL CHANGE

9
extra/irc/ui/ircui-rc Executable file
View File

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

16
extra/irc/ui/load/load.factor Executable file
View File

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

View File

@ -3,12 +3,17 @@
USING: accessors kernel threads combinators concurrency.mailboxes USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables sequences strings hashtables splitting fry assocs hashtables
ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
io io.styles namespaces irc.client irc.messages ; 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 IN: irc.ui
SYMBOL: listener
SYMBOL: client SYMBOL: client
TUPLE: ui-window client tabs ; TUPLE: ui-window client tabs ;
@ -19,36 +24,45 @@ TUPLE: ui-window client tabs ;
: green { 0 0.5 0 1 } ; : green { 0 0.5 0 1 } ;
: blue { 0 0 1 1 } ; : blue { 0 0 1 1 } ;
: prefix>nick ( prefix -- nick ) : dot-or-parens ( string -- string )
"!" split first ; dup empty? [ drop "." ]
[ "(" prepend ")" append ] if ;
GENERIC: write-irc ( irc-message -- ) GENERIC: write-irc ( irc-message -- )
M: privmsg write-irc M: privmsg write-irc
"<" blue write-color "<" blue write-color
[ prefix>> prefix>nick write ] keep [ prefix>> parse-name write ] keep
"> " blue write-color "> " blue write-color
" " write
trailing>> write ; trailing>> write ;
TUPLE: own-message message nick timestamp ;
: <own-message> ( 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 M: join write-irc
"* " green write-color "* " green write-color
prefix>> prefix>nick write prefix>> parse-name write
" has entered the channel." green write-color ; " has entered the channel." green write-color ;
M: part write-irc M: part write-irc
"* " red write-color "* " red write-color
[ prefix>> prefix>nick write ] keep [ prefix>> parse-name write ] keep
" has left the channel(" red write-color " has left the channel" red write-color
trailing>> write trailing>> dot-or-parens red write-color ;
")" red write-color ;
M: quit write-irc M: quit write-irc
"* " red write-color "* " red write-color
[ prefix>> prefix>nick write ] keep [ prefix>> parse-name write ] keep
" has left IRC(" red write-color " has left IRC" red write-color
trailing>> write trailing>> dot-or-parens red write-color ;
")" red write-color ;
M: irc-end write-irc M: irc-end write-irc
drop "* You have left IRC" red write-color ; 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 drop ; ! catch all unimplemented writes, THIS WILL CHANGE
: print-irc ( irc-message -- ) : print-irc ( irc-message -- )
write-irc nl ; [ timestamp>> timestamp>hms write " " write ]
[ write-irc nl ] bi ;
: send-message ( message listener client -- ) : send-message ( message -- )
"<" blue write-color [ print-irc ]
profile>> nickname>> bold font-style associate format [ listener get write-message ] bi ;
">" blue write-color
" " write
over write nl
out-messages>> mailbox-put ;
: display ( stream listener -- ) : display ( stream listener -- )
'[ , [ [ t ] '[ , [ [ t ]
@ -84,35 +95,44 @@ M: irc-message write-irc
TUPLE: irc-editor < editor outstream listener client ; TUPLE: irc-editor < editor outstream listener client ;
: <irc-editor> ( pane listener client -- editor ) : <irc-editor> ( page pane listener -- client editor )
[ irc-editor new-editor irc-editor new-editor
swap >>listener swap <pane-stream> >>outstream swap >>listener swap <pane-stream> >>outstream
] dip client>> >>client ; over client>> >>client ;
: editor-send ( irc-editor -- ) : editor-send ( irc-editor -- )
{ [ outstream>> ] { [ outstream>> ]
[ editor-string ]
[ listener>> ] [ listener>> ]
[ client>> ] [ client>> ]
[ editor-string ]
[ "" swap set-editor-string ] } cleave [ "" swap set-editor-string ] } cleave
'[ , , , send-message ] with-output-stream ; '[ , listener set , client set , parse-message ] with-output-stream ;
irc-editor "general" f { irc-editor "general" f {
{ T{ key-down f f "RET" } editor-send } { T{ key-down f f "RET" } editor-send }
{ T{ key-down f f "ENTER" } editor-send } { T{ key-down f f "ENTER" } editor-send }
} define-command-map } define-command-map
: irc-page ( name pane editor tabbed -- ) TUPLE: irc-page < frame listener client ;
[ [ <scroller> @bottom frame, ! editor
<scroller> @center frame, ! pane : <irc-page> ( listener client -- irc-page )
] make-frame swap ] dip add-page ; irc-page new-frame
swap client>> >>client swap [ >>listener ] keep
[ <irc-pane> [ <scroller> @center grid-add* ] keep ]
[ <irc-editor> <scroller> @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 -- ) : join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip [ dup <irc-channel-listener> ] dip
[ client>> add-listener ] [ <irc-page> swap ] keep
[ drop <irc-pane> dup ] tabs>> add-page ;
[ [ <irc-editor> ] keep ] 2tri
tabs>> irc-page ;
: irc-window ( ui-window -- ) : irc-window ( ui-window -- )
[ tabs>> ] [ tabs>> ]
@ -125,6 +145,10 @@ irc-editor "general" f {
[ listeners>> +server-listener+ swap at <irc-pane> <scroller> [ listeners>> +server-listener+ swap at <irc-pane> <scroller>
"Server" associate <tabbed> >>tabs ] bi ; "Server" associate <tabbed> >>tabs ] bi ;
: freenode-connect ( -- ui-window ) : server-open ( server port nick password channels -- )
"irc.freenode.org" 8001 "factor-irc" f [ <irc-profile> ui-connect [ irc-window ] keep ] dip
<irc-profile> ui-connect [ irc-window ] keep ; [ over join-channel ] each ;
: main-run ( -- ) run-ircui ;
MAIN: main-run

View File

@ -49,7 +49,7 @@ kernel strings ;
{ { object ppc object } "b" } { { object ppc object } "b" }
{ { string object windows } "c" } { { string object windows } "c" }
} }
V{ cpu os } { cpu os }
] [ ] [
example-1 canonicalize-specializers example-1 canonicalize-specializers
] unit-test ] unit-test

View File

@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
] unit-test ] unit-test
[ [
"USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
] must-fail ] must-fail
{ t } [ { t } [

View File

@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
M: ebnf-rule (transform) ( ast -- parser ) M: ebnf-rule (transform) ( ast -- parser )
dup elements>> dup elements>>
(transform) [ (transform) [
swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [ swap symbol>> dup get parser? [
"Rule '" over append "' defined more than once" append throw "Rule '" over append "' defined more than once" append throw
] [ ] [
set set