remove math.blas.syntax and merge parsing words into math.blas.vectors/matrices

[factor/jcg.git] / extra / irc / ui / ui.factor

! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
USING: accessors kernel threads combinators concurrency.mailboxes\r
       sequences strings hashtables splitting fry assocs hashtables colors\r
       sorting unicode.collation math.order\r
       ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
       ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
       ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
       io io.styles namespaces calendar calendar.format models continuations\r
       irc.client irc.client.private irc.messages\r
       irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
\r
RENAME: join sequences => sjoin\r
\r
IN: irc.ui\r
\r
SYMBOL: chat\r
\r
SYMBOL: client\r
\r
TUPLE: ui-window < tabbed client ;\r
\r
M: ui-window ungraft*\r
    client>> terminate-irc ;\r
\r
TUPLE: irc-tab < frame chat client window ;\r
\r
: write-color ( str color -- )\r
    foreground associate format ;\r
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;\r
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;\r
: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;\r
\r
: dot-or-parens ( string -- string )\r
    [ "." ]\r
    [ "(" prepend ")" append ] if-empty ;\r
\r
GENERIC: write-irc ( irc-message -- )\r
\r
M: ping write-irc\r
    drop "* Ping" blue write-color ;\r
\r
M: privmsg write-irc\r
    "<" dark-blue write-color\r
    [ irc-message-sender write ] keep\r
    "> " dark-blue write-color\r
    trailing>> write ;\r
\r
M: notice write-irc\r
    [ type>> dark-blue write-color ] keep\r
    ": " dark-blue write-color\r
    trailing>> write ;\r
\r
TUPLE: own-message message nick timestamp ;\r
\r
: <own-message> ( message nick -- own-message )\r
    now own-message boa ;\r
\r
M: own-message write-irc\r
    "<" dark-blue write-color\r
    [ nick>> bold font-style associate format ] keep\r
    "> " dark-blue write-color\r
    message>> write ;\r
\r
M: join write-irc\r
    "* " dark-green write-color\r
    irc-message-sender write\r
    " has entered the channel." dark-green write-color ;\r
\r
M: part write-irc\r
    "* " dark-red write-color\r
    [ irc-message-sender write ] keep\r
    " has left the channel" dark-red write-color\r
    trailing>> dot-or-parens dark-red write-color ;\r
\r
M: quit write-irc\r
    "* " dark-red write-color\r
    [ irc-message-sender write ] keep\r
    " has left IRC" dark-red write-color\r
    trailing>> dot-or-parens dark-red write-color ;\r
\r
M: kick write-irc\r
    "* " dark-red write-color\r
    [ irc-message-sender write ] keep\r
    " has kicked " dark-red write-color\r
    [ who>> write ] keep\r
    " from the channel" dark-red write-color\r
    trailing>> dot-or-parens dark-red write-color ;\r
\r
M: mode write-irc\r
    "* " dark-blue write-color\r
    [ name>> write ] keep\r
    " has applied mode " dark-blue write-color\r
    [ mode>> write ] keep\r
    " to " dark-blue write-color\r
    parameter>> write ;\r
\r
M: nick write-irc\r
    "* " dark-blue write-color\r
    [ irc-message-sender write ] keep\r
    " is now known as " blue write-color\r
    trailing>> write ;\r
\r
M: unhandled write-irc\r
    "UNHANDLED: " write\r
    line>> dark-blue write-color ;\r
\r
M: irc-end write-irc\r
    drop "* You have left IRC" dark-red write-color ;\r
\r
M: irc-disconnected write-irc\r
    drop "* Disconnected" dark-red write-color ;\r
\r
M: irc-connected write-irc\r
    drop "* Connected" dark-green write-color ;\r
\r
M: irc-chat-end write-irc\r
    drop ;\r
\r
M: irc-message write-irc\r
    "UNIMPLEMENTED" write\r
    [ class pprint ] keep\r
    ": " write\r
    line>> dark-blue write-color ;\r
\r
GENERIC: time-happened ( message -- timestamp )\r
\r
M: irc-message time-happened timestamp>> ;\r
\r
M: object time-happened drop now ;\r
\r
: print-irc ( irc-message -- )\r
    [ time-happened timestamp>hms write " " write ]\r
    [ write-irc nl ] bi ;\r
\r
: send-message ( message -- )\r
    [ print-irc ]\r
    [ chat get speak ] bi ;\r
\r
GENERIC: handle-inbox ( tab message -- )\r
\r
: value-labels ( assoc val -- seq )\r
    '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
\r
: add-gadget-color ( pack seq color -- pack )\r
    '[ _ >>color add-gadget ] each ;\r
\r
M: object handle-inbox\r
    nip print-irc ;\r
\r
: display ( stream tab -- )\r
    '[ _ [ [ t ]\r
           [ _ dup chat>> hear handle-inbox ]\r
           [  ] while ] with-output-stream ] "ircv" spawn drop ;\r
\r
: <irc-pane> ( tab -- tab pane )\r
    <scrolling-pane>\r
    [ <pane-stream> swap display ] 2keep ;\r
\r
TUPLE: irc-editor < editor outstream tab ;\r
\r
: <irc-editor> ( tab pane -- tab editor )\r
    irc-editor new-editor\r
    swap <pane-stream> >>outstream ;\r
\r
: editor-send ( irc-editor -- )\r
    { [ outstream>> ]\r
      [ [ irc-tab? ] find-parent ]\r
      [ editor-string ]\r
      [ "" swap set-editor-string ] } cleave\r
     '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
\r
irc-editor "general" f {\r
    { T{ key-down f f "RET" } editor-send }\r
    { T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
: new-irc-tab ( chat ui-window class -- irc-tab )\r
    new-frame\r
    swap >>window\r
    swap >>chat\r
    <irc-pane> [ <scroller> @center grid-add ] keep\r
    <irc-editor> <scroller> @bottom grid-add ;\r
\r
M: irc-tab graft*\r
    [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
\r
M: irc-tab ungraft*\r
    chat>> detach-chat ;\r
\r
TUPLE: irc-channel-tab < irc-tab userlist ;\r
\r
: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
    irc-channel-tab new-irc-tab\r
    <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
\r
: update-participants ( tab -- )\r
    [ userlist>> [ clear-gadget ] keep ]\r
    [ chat>> participants>> ] bi\r
    [ +operator+ value-labels dark-green add-gadget-color ]\r
    [ +voice+ value-labels blue add-gadget-color ]\r
    [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
\r
M: participant-changed handle-inbox\r
    drop update-participants ;\r
\r
TUPLE: irc-server-tab < irc-tab ;\r
\r
: <irc-server-tab> ( chat -- irc-tab )\r
    f irc-server-tab new-irc-tab ;\r
\r
: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
    irc-tab new-irc-tab ;\r
\r
M: irc-tab pref-dim*\r
    drop { 480 480 } ;\r
\r
: join-channel ( name ui-window -- )\r
    [ dup <irc-channel-chat> ] dip\r
    [ <irc-channel-tab> swap ] keep\r
    add-page ;\r
\r
: query-nick ( nick ui-window -- )\r
    [ dup <irc-nick-chat> ] dip\r
    [ <irc-nick-tab> swap ] keep\r
    add-page ;\r
\r
: irc-window ( ui-window -- )\r
    [ ]\r
    [ client>> profile>> server>> ] bi\r
    open-window ;\r
\r
: ui-connect ( profile -- ui-window )\r
    <irc-client>\r
    { [ [ <irc-server-chat> ] dip attach-chat ]\r
      [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
        "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
      [ >>client ]\r
      [ connect-irc ] } cleave ;\r
\r
: server-open ( server port nick password channels -- )\r
    [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
    [ over join-channel ] each drop ;\r
\r
: main-run ( -- ) run-ircui ;\r
\r
MAIN: main-run\r
\r
"irc.ui.commands" require\r