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

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

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 ] [

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

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 <channel>
     [ 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 <channel>
     [ 4 swap to ] in-thread
     [ 2 swap to ] in-thread

extra/farkup/authors.factor

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

extra/farkup/authors.txt

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

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
 
-[ "<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><strong>Wow!</strong></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
 
-[ "" ] [ "\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\r\n\r\nbar" 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>" ] [ "\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
 
@@ -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
 
 [
-    "<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
-
-[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
-[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test

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
+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
 
 SYMBOL: relative-link-prefix
 SYMBOL: disable-images?
 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');" ;
 
@@ -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
-    [
+    "<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 [
-        2drop "<strong>Images are not allowed</strong>"
+        2drop "<strong>Images are not allowed</strong>" write
     ] [
         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 ;
 
-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' )
-    parse-farkup [ write-farkup ] with-string-writer ;
+    farkup [ write-farkup ] with-string-writer ;

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

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
+       continuations threads strings classes combinators splitting hashtables
-       irc.messages irc.messages.private ;
+       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+
      <mailbox> <mailbox> irc-server-listener boa ;
 
 : <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 )
-     <mailbox> <mailbox> rot irc-nick-listener boa ;
+     [ <mailbox> <mailbox> ] 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 ]
+    [ [ irc-end ] dip in-messages>> mailbox-put ]
-    [ f >>is-running drop ]
+    [ [ 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
+    [ maybe-forward-join ]
-      [ irc> join-messages>> mailbox-put ] when* ]
     [ 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
+    [ 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 -- )
     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
+    [ 5 seconds ] dip
-    '[ , , , mailbox-get-timeout swap call ]
+    '[ , , ,  [ 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
+    [ [ name>> ] [ out-messages>> ] bi
-      \ part new swap >>channel mailbox-put ] keep
+      [ [ 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>
 

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
+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
 
 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" ;
+
 <PRIVATE
 ! ======================================
 ! Message parsing
@@ -55,6 +70,7 @@ TUPLE: unhandled < irc-message ;
         { "NOTICE" [ \ notice ] }
         { "001" [ \ logged-in ] }
         { "433" [ \ nick-in-use ] }
+        { "353" [ \ names-reply ] }
         { "JOIN" [ \ join ] }
         { "PART" [ \ part ] }
         { "PRIVMSG" [ \ privmsg ] }

extra/irc/ui/commandparser/commandparser.factor

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

extra/irc/ui/commands/commands.factor

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

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

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 ;

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 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
 
+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 )
+: dot-or-parens ( string -- string )
-    "!" split first ;
+    dup empty? [ drop "." ]
+    [ "(" prepend ")" append ] if ;
 
 GENERIC: write-irc ( irc-message -- )
 
 M: privmsg write-irc
     "<" blue write-color
-    [ prefix>> prefix>nick write ] keep
+    [ prefix>> parse-name write ] keep
     "> " blue write-color
-    " " 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
     "* " 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
+    [ 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
     "* " 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
     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 -- )
+: 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 -- )
     '[ , [ [ t ]
@@ -84,35 +95,44 @@ M: irc-message write-irc
 
 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
-    ] 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 -- )
+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 -- )
     [ 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 -- )
     [ tabs>> ]
@@ -125,6 +145,10 @@ irc-editor "general" f {
     [ listeners>> +server-listener+ swap at <irc-pane> <scroller>
       "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

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

extra/peg/ebnf/ebnf-tests.factor

@@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
 ] 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
 
 { t } [

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