From aec887cc140ea08ebf1ea1701a70869e90b96003 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 11 Jul 2008 01:16:15 -0300 Subject: [PATCH 01/13] irc.client: Handling of lists of participants in channels, fixes. --- extra/irc/client/client.factor | 45 +++++++++++++++++++++++------- extra/irc/messages/messages.factor | 4 ++- 2 files changed, 38 insertions(+), 11 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 472805f5ae..7ab0ea1ab1 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,7 +37,7 @@ SYMBOL: +server-listener+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds irc-channel-listener boa ; + rot f 60 seconds H{ } clone irc-channel-listener boa ; : ( name -- irc-nick-listener ) rot irc-nick-listener boa ; @@ -74,6 +74,18 @@ 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* ; + +: 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 ! ====================================== @@ -153,17 +165,30 @@ 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 ; + [ [ ] [ channel>> ] bi to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ [ ] [ who>> ] bi me? [ unregister-listener ] [ drop ] if ] + tri ; + +: >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 ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index f1beba9b26..fb41997b84 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -7,7 +7,7 @@ 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,6 +16,7 @@ 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 ; Date: Fri, 11 Jul 2008 17:11:03 -0400 Subject: [PATCH 02/13] irc.ui now has timestamps --- extra/irc/ui/ui.factor | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index cc138dad92..54a177f613 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -5,7 +5,8 @@ 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 ; + io io.styles namespaces irc.client irc.messages calendar + calendar.format ; IN: irc.ui @@ -27,10 +28,20 @@ GENERIC: write-irc ( irc-message -- ) M: privmsg write-irc "<" blue write-color [ prefix>> prefix>nick write ] keep - ">" blue write-color - " " write + "> " 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 @@ -63,15 +74,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 ; + [ nip profile>> nickname>> print-irc ] + [ drop write-message ] 3bi ; : display ( stream listener -- ) '[ , [ [ t ] From b68a982466bb93f9d4af23dd490b5c1e6e1a8a0f Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Fri, 11 Jul 2008 20:23:31 -0300 Subject: [PATCH 03/13] irc.client: Some little changes, and handling of quit messages (removes participant from channels, still needs to forward it) --- extra/irc/client/client.factor | 46 ++++++++++++++++-------------- extra/irc/messages/messages.factor | 18 ++++++++++-- 2 files changed, 40 insertions(+), 24 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 7ab0ea1ab1..fb010dbc86 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -37,10 +37,10 @@ SYMBOL: +server-listener+ irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds H{ } clone 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 ; @@ -77,6 +77,11 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : 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* ; @@ -90,14 +95,6 @@ DEFER: me? ! 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 ; @@ -111,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 @@ -175,11 +172,15 @@ M: part handle-incoming-irc ( part -- ) [ prefix>> parse-name ] [ channel>> ] bi remove-participant ; M: kick handle-incoming-irc ( kick -- ) - [ [ ] [ channel>> ] bi to-listener ] + [ dup channel>> to-listener ] [ [ who>> ] [ channel>> ] bi remove-participant ] - [ [ ] [ who>> ] bi me? [ unregister-listener ] [ drop ] if ] + [ 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 ; @@ -213,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 -- ) @@ -224,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 ; @@ -300,7 +302,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 -- ) @@ -309,7 +311,7 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) [ [ out-messages>> ] [ name>> ] bi - \ part new swap >>channel mailbox-put ] keep + [ \ part new ] dip >>channel mailbox-put ] keep name>> unregister-listener ; M: irc-server-listener (remove-listener) ( irc-server-listener -- ) @@ -319,10 +321,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 fb41997b84..205630d790 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,7 +1,9 @@ ! 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 ; @@ -19,6 +21,18 @@ 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" ; + Date: Sat, 12 Jul 2008 00:04:39 -0300 Subject: [PATCH 04/13] irc.client: Fix, remove-listener now parts from channels correctly --- extra/irc/client/client.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index fb010dbc86..2dbbe8b8f5 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -206,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 ; ! ====================================== @@ -263,6 +263,7 @@ DEFER: (connect-irc) { { [ dup string? ] [ strings>privmsg ] } { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; : listener-loop ( name listener -- ) @@ -310,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 ] dip >>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 -- ) From 3928d3dae0637bbf017ed144c9ecbf447b0a3622 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Mon, 14 Jul 2008 20:53:08 -0400 Subject: [PATCH 05/13] Added /commands --- .../irc/ui/commandparser/commandparser.factor | 16 ++++ extra/irc/ui/commands/commands.factor | 13 ++++ extra/irc/ui/ui.factor | 73 +++++++++++-------- 3 files changed, 72 insertions(+), 30 deletions(-) create mode 100755 extra/irc/ui/commandparser/commandparser.factor create mode 100755 extra/irc/ui/commands/commands.factor diff --git a/extra/irc/ui/commandparser/commandparser.factor b/extra/irc/ui/commandparser/commandparser.factor new file mode 100755 index 0000000000..7a048c13b1 --- /dev/null +++ b/extra/irc/ui/commandparser/commandparser.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel vocabs.loader sequences strings irc.messages ; + +IN: irc.ui.commandparser + +"irc.ui.commands" require + +: command ( string -- command ) + dup empty? [ drop "say" ] when + dup "irc.ui.commands" lookup + [ "quote" "irc.ui.commands" lookup ] unless* ; + +: parse-message ( string -- ) + "/" head? [ " " split1 swap command execute ] when ; diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor new file mode 100755 index 0000000000..9f062f7d11 --- /dev/null +++ b/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: kernel irc.client irc.messages irc.ui + +IN: irc.ui.commands + +: say ( string -- ) + [ client get profile>> nickname>> print-irc ] + [ listener get write-message ] bi ; + +: quote ( string -- ) + drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 54a177f613..dba3f2255c 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -3,13 +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 calendar - calendar.format ; + 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 irc.client irc.client.private + irc.messages irc.messages.private irc.ui.commandparser + calendar calendar.format ; IN: irc.ui +SYMBOL: listener + SYMBOL: client TUPLE: ui-window client tabs ; @@ -20,14 +24,15 @@ 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 + [ prefix>> parse-name write ] keep "> " blue write-color trailing>> write ; @@ -44,22 +49,20 @@ M: own-message write-irc 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 ; @@ -77,9 +80,9 @@ M: irc-message write-irc [ timestamp>> timestamp>hms write " " write ] [ write-irc nl ] bi ; -: send-message ( message listener client -- ) - [ nip profile>> nickname>> print-irc ] - [ drop write-message ] 3bi ; +: send-message ( message -- ) + [ print-irc ] + [ listener get write-message ] bi ; : display ( stream listener -- ) '[ , [ [ t ] @@ -95,32 +98,42 @@ TUPLE: irc-editor < editor outstream listener client ; : ( pane listener client -- editor ) [ irc-editor new-editor swap >>listener swap >>outstream - ] dip client>> >>client ; + ] dip >>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 + [ g swap client>> >>client swap [ swap (>>listener) ] keep + [ [ g @center grid-add ] keep ] + [ g client>> g @bottom grid-add ] bi + g ] with-gadget ; + +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>> ] From 3f68fb46189abba9f28f4fba393d52e230b30f2b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 15 Jul 2008 15:42:13 +1200 Subject: [PATCH 06/13] Fix regression where multiply defined ebnf rules didn't result in an error --- extra/peg/ebnf/ebnf-tests.factor | 4 ++-- extra/peg/ebnf/ebnf.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) 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 From c02397d3a4eb12bca2e6bdf8b3f6c94decd4412e Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Tue, 15 Jul 2008 02:46:49 -0400 Subject: [PATCH 07/13] Got /commands actually working, irc.ui no longer uses make-gadget et al --- extra/irc/ui/commandparser/commandparser.factor | 9 +++++---- extra/irc/ui/commands/commands.factor | 2 +- extra/irc/ui/ui.factor | 13 ++++++------- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/irc/ui/commandparser/commandparser.factor b/extra/irc/ui/commandparser/commandparser.factor index 7a048c13b1..2835023c0d 100755 --- a/extra/irc/ui/commandparser/commandparser.factor +++ b/extra/irc/ui/commandparser/commandparser.factor @@ -1,16 +1,17 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel vocabs.loader sequences strings irc.messages ; +USING: kernel vocabs.loader sequences strings splitting words irc.messages ; IN: irc.ui.commandparser "irc.ui.commands" require -: command ( string -- command ) +: command ( string string -- string command ) dup empty? [ drop "say" ] when dup "irc.ui.commands" lookup - [ "quote" "irc.ui.commands" lookup ] unless* ; + [ nip ] + [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ; : parse-message ( string -- ) - "/" head? [ " " split1 swap command execute ] when ; + "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ; diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor index 9f062f7d11..59f4526d23 100755 --- a/extra/irc/ui/commands/commands.factor +++ b/extra/irc/ui/commands/commands.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel irc.client irc.messages irc.ui +USING: accessors kernel irc.client irc.messages irc.ui namespaces ; IN: irc.ui.commands diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index dba3f2255c..2266c51f41 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -95,10 +95,10 @@ 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 ; + over client>> >>client ; : editor-send ( irc-editor -- ) { [ outstream>> ] @@ -117,10 +117,9 @@ TUPLE: irc-page < frame listener client ; : ( listener client -- irc-page ) irc-page new-frame - [ g swap client>> >>client swap [ swap (>>listener) ] keep - [ [ g @center grid-add ] keep ] - [ g client>> g @bottom grid-add ] bi - g ] with-gadget ; + swap client>> >>client swap [ >>listener ] keep + [ [ @center grid-add* ] keep ] + [ @bottom grid-add* ] bi ; M: irc-page graft* [ listener>> ] [ client>> ] bi From 36e74f29c0c94db9b04227ab7e1e18cba8260b18 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 16 Jul 2008 00:02:04 -0400 Subject: [PATCH 08/13] Added irc.ui.load; now "irc.ui" run works --- extra/irc/ui/ircui-rc | 9 +++++++++ extra/irc/ui/load/load.factor | 16 ++++++++++++++++ extra/irc/ui/ui.factor | 16 ++++++++++------ 3 files changed, 35 insertions(+), 6 deletions(-) create mode 100755 extra/irc/ui/ircui-rc create mode 100755 extra/irc/ui/load/load.factor 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 2266c51f41..12f9d01183 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -6,9 +6,9 @@ USING: accessors kernel threads combinators concurrency.mailboxes 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 irc.client irc.client.private - irc.messages irc.messages.private irc.ui.commandparser - calendar calendar.format ; + 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 @@ -145,6 +145,10 @@ M: irc-page ungraft* [ 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 From f4e34ce0e1cbb3422f679e1f5df2144ab0a7100f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Jul 2008 23:42:34 -0500 Subject: [PATCH 09/13] remove the old farkup --- extra/farkup/authors.factor | 2 - extra/farkup/authors.txt | 1 - extra/farkup/farkup-docs.factor | 6 - extra/farkup/farkup-tests.factor | 84 ------------- extra/farkup/farkup.factor | 200 ------------------------------- extra/farkup/summary.txt | 1 - extra/farkup/tags.txt | 1 - 7 files changed, 295 deletions(-) delete mode 100644 extra/farkup/authors.factor delete mode 100644 extra/farkup/authors.txt delete mode 100644 extra/farkup/farkup-docs.factor delete mode 100755 extra/farkup/farkup-tests.factor delete mode 100755 extra/farkup/farkup.factor delete mode 100644 extra/farkup/summary.txt delete mode 100644 extra/farkup/tags.txt 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 deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/farkup/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor deleted file mode 100644 index b2b662db82..0000000000 --- a/extra/farkup/farkup-docs.factor +++ /dev/null @@ -1,6 +0,0 @@ -USING: help.markup help.syntax ; -IN: farkup - -HELP: convert-farkup -{ $values { "string" "a string" } { "string'" "a string" } } -{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor deleted file mode 100755 index 17d286252e..0000000000 --- a/extra/farkup/farkup-tests.factor +++ /dev/null @@ -1,84 +0,0 @@ -USING: farkup kernel 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 - -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" 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 - -[ "

*

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

*

" ] [ "\\*" 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 -[ "

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

foo

bar

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

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test -[ "\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 - -[ "" ] [ "" convert-farkup ] unit-test - -[ "

|a

" ] -[ "|a" convert-farkup ] unit-test - -[ "
a
" ] -[ "|a|" convert-farkup ] unit-test - -[ "
ab
" ] -[ "|a|b|" convert-farkup ] unit-test - -[ "
ab
cd
" ] -[ "|a|b|\n|c|d|" convert-farkup ] unit-test - -[ "
ab
cd
" ] -[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test - -[ "

foo\n

aheading

\n

adfasd

" ] -[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test - -[ "

foo

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

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test -[ "

=foo\n

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

=foo

" ] [ "=foo" convert-farkup ] unit-test -[ "

==foo

" ] [ "==foo" convert-farkup ] unit-test -[ "

=

foo

" ] [ "==foo=" convert-farkup ] unit-test -[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test -[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test -[ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test -[ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test - -[ "
int main()\n
" ] -[ "[c{int main()}]" convert-farkup ] unit-test - -[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test -[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test -[ "

lol.com

" ] [ "[[lol.com]]" convert-farkup ] unit-test -[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test - -[ ] [ "[{}]" convert-farkup drop ] unit-test - -[ - "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" -] [ "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:\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 deleted file mode 100755 index 321648136a..0000000000 --- a/extra/farkup/farkup.factor +++ /dev/null @@ -1,200 +0,0 @@ -! 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 ; -IN: farkup - -SYMBOL: relative-link-prefix -SYMBOL: disable-images? -SYMBOL: link-no-follow? - -string escape-string ] action ; - -MEMO: delimiter ( -- parser ) - [ dup delimiters member? swap "\r\n=" member? not and ] satisfy - [ 1string ] action ; - -: surround-with-foo ( string tag -- seq ) - dup swap swapd 3array ; - -: delimited ( str html -- parser ) - [ - over token hide , - text [ surround-with-foo ] swapd curry action , - token hide , - ] seq* ; - -MEMO: escaped-char ( -- parser ) - [ "\\" token hide , any-char , ] seq* [ >string ] action ; - -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 ; - -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');" ; - -: check-url ( href -- href' ) - { - { [ dup empty? ] [ drop invalid-url ] } - { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } - { [ dup first "/\\" member? ] [ drop invalid-url ] } - { [ CHAR: : over member? ] [ - dup { "http://" "https://" "ftp://" } [ head? ] with contains? - [ drop invalid-url ] unless - ] } - [ relative-link-prefix get prepend ] - } cond ; - -: escape-link ( href text -- href-esc text-esc ) - >r check-url escape-quoted-string r> escape-string ; - -: make-link ( href text -- seq ) - escape-link - [ - "r , r> "\"" , - link-no-follow? get [ " nofollow=\"true\"" , ] when - ">" , , "" , - ] { } make ; - -: make-image-link ( href alt -- seq ) - disable-images? get [ - 2drop "Images are not allowed" - ] [ - escape-link - [ - "\""" , - ] { } make - ] if ; - -MEMO: image-link ( -- parser ) - [ - "[[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 ; - -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 ; - -: convert-farkup ( string -- string' ) - parse-farkup [ write-farkup ] with-string-writer ; diff --git a/extra/farkup/summary.txt b/extra/farkup/summary.txt deleted file mode 100644 index c6e75d28a9..0000000000 --- a/extra/farkup/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Simple markup language for generating HTML diff --git a/extra/farkup/tags.txt b/extra/farkup/tags.txt deleted file mode 100644 index 8e27be7d61..0000000000 --- a/extra/farkup/tags.txt +++ /dev/null @@ -1 +0,0 @@ -text From cbf190ab764fc37552c864932cd4ccf6cb683888 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Jul 2008 23:56:25 -0500 Subject: [PATCH 10/13] the new farkup using ebnf removed authors.factor which shouldn't have been there anyway --- extra/farkup/authors.txt | 2 + extra/farkup/farkup-docs.factor | 6 ++ extra/farkup/farkup-tests.factor | 97 +++++++++++++++++ extra/farkup/farkup.factor | 180 +++++++++++++++++++++++++++++++ extra/farkup/summary.txt | 1 + extra/farkup/tags.txt | 1 + 6 files changed, 287 insertions(+) create mode 100644 extra/farkup/authors.txt create mode 100644 extra/farkup/farkup-docs.factor create mode 100644 extra/farkup/farkup-tests.factor create mode 100644 extra/farkup/farkup.factor create mode 100644 extra/farkup/summary.txt create mode 100644 extra/farkup/tags.txt diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/farkup/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/farkup/farkup-docs.factor b/extra/farkup/farkup-docs.factor new file mode 100644 index 0000000000..b2b662db82 --- /dev/null +++ b/extra/farkup/farkup-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax ; +IN: farkup + +HELP: convert-farkup +{ $values { "string" "a string" } { "string'" "a string" } } +{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ; diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor new file mode 100644 index 0000000000..005e875d89 --- /dev/null +++ b/extra/farkup/farkup-tests.factor @@ -0,0 +1,97 @@ +! 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 + +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23" + "paragraph" \ farkup rule parse drop +] 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 + +[ "

*

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

*

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

**

" ] [ "\\**" 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 +[ "

foo

bar

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

bar\n

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

bar\n

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

bar\n

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

foo

bar

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

|a

" ] +[ "|a" convert-farkup ] unit-test + +[ "
a
" ] +[ "|a|" convert-farkup ] unit-test + +[ "
ab
" ] +[ "|a|b|" convert-farkup ] unit-test + +[ "
ab
cd
" ] +[ "|a|b|\n|c|d|" convert-farkup ] unit-test + +[ "
ab
cd
" ] +[ "|a|b|\n|c|d|\n" convert-farkup ] unit-test + +[ "

foo\n

aheading

\n

adfasd

" ] +[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test + +[ "

foo

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

lol

foo

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

=foo\n

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

=foo

" ] [ "=foo" convert-farkup ] unit-test +[ "

==foo

" ] [ "==foo" convert-farkup ] unit-test +[ "

=

foo

" ] [ "==foo=" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

foo

" ] [ "==foo==" convert-farkup ] unit-test +[ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test +[ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test + +[ "
int main()\n
" ] +[ "[c{int main()}]" convert-farkup ] unit-test + +[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test +[ "

lol.com

" ] [ "[[lol.com]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test + +[ ] [ "[{}]" convert-farkup drop ] unit-test + +[ + "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" +] [ "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:

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 diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor new file mode 100644 index 0000000000..baf2ccaba2 --- /dev/null +++ b/extra/farkup/farkup.factor @@ -0,0 +1,180 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +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? + +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 ; + +EBNF: farkup +nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] +2nl = nl nl + +heading1 = "=" (!("=" | nl).)+ "=" + => [[ second >string heading1 boa ]] + +heading2 = "==" (!("=" | nl).)+ "==" + => [[ second >string heading2 boa ]] + +heading3 = "===" (!("=" | nl).)+ "===" + => [[ second >string heading3 boa ]] + +heading4 = "====" (!("=" | nl).)+ "====" + => [[ second >string heading4 boa ]] + +strong = "*" (!("*" | nl).)+ "*" + => [[ second >string strong boa ]] + +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 + + + +: invalid-url "javascript:alert('Invalid URL in farkup');" ; + +: check-url ( href -- href' ) + { + { [ dup empty? ] [ drop invalid-url ] } + { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } + { [ dup first "/\\" member? ] [ drop invalid-url ] } + { [ CHAR: : over member? ] [ + dup { "http://" "https://" "ftp://" } [ head? ] with contains? + [ drop invalid-url ] unless + ] } + [ relative-link-prefix get prepend ] + } cond ; + +: escape-link ( href text -- href-esc text-esc ) + >r check-url escape-quoted-string r> escape-string ; + +: write-link ( text href -- ) + escape-link + "" write write "" write ; + +: write-image-link ( href text -- ) + disable-images? get [ + 2drop "Images are not allowed" write + ] [ + escape-link + >r " + dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if + "/>" write + ] if ; + +: render-code ( string mode -- string' ) + >r string-lines r> + [ + 
+            htmlize-lines
+
+ ] with-string-writer write ; + +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' ) + farkup [ write-farkup ] with-string-writer ; diff --git a/extra/farkup/summary.txt b/extra/farkup/summary.txt new file mode 100644 index 0000000000..c6e75d28a9 --- /dev/null +++ b/extra/farkup/summary.txt @@ -0,0 +1 @@ +Simple markup language for generating HTML diff --git a/extra/farkup/tags.txt b/extra/farkup/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/farkup/tags.txt @@ -0,0 +1 @@ +text From bb516f3a6f8ad538fec2799a0e409ad44f595e98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jul 2008 01:03:27 -0500 Subject: [PATCH 11/13] New benchmark --- extra/benchmark/backtrack/backtrack.factor | 65 ++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 extra/benchmark/backtrack/backtrack.factor 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 ; From f64f55ba2294aef9793af257e3d45a40ea8b3a27 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jul 2008 01:03:41 -0500 Subject: [PATCH 12/13] Fix test failures --- core/compiler/tests/stack-trace.factor | 7 ------- core/optimizer/optimizer-tests.factor | 4 ++-- extra/channels/channels-tests.factor | 4 ++-- extra/multi-methods/tests/canonicalize.factor | 2 +- 4 files changed, 5 insertions(+), 12 deletions(-) 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/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/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 From de9183bb88f9306ded4ef382d5842d2c40103020 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jul 2008 05:24:16 -0500 Subject: [PATCH 13/13] HTML components tests fixed --- extra/html/components/components-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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