manatee-ircclient 0.0.6 → 0.0.7
raw patch · 12 files changed
+524/−194 lines, 12 filesdep +ghcdep ~manatee-coresetup-changed
Dependencies added: ghc
Dependency ranges changed: manatee-core
Files
- Config/Default.hs +91/−0
- Config/Import.hs +21/−0
- Config/IrcClient.hs +91/−0
- Config/User.hs +19/−0
- Main.hs +6/−2
- Manatee/Extension/IrcClient/Daemon.hs +0/−2
- Manatee/Extension/IrcClient/IrcBuffer.hs +141/−74
- Manatee/Extension/IrcClient/IrcView.hs +24/−10
- Manatee/Extension/IrcClient/Smile.hs +1/−1
- Manatee/Extension/IrcClient/Types.hs +83/−83
- Setup.hs +16/−1
- manatee-ircclient.cabal +31/−21
+ Config/Default.hs view
@@ -0,0 +1,91 @@+-- Author: Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved.+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Config.Default where++import Graphics.UI.Gtk.Gdk.GC (Color (..))+import Graphics.UI.Gtk.General.Enums (TextWindowType (..))+import Language.Translate.Google++-- | Self message color.+selfMsgColor :: Color+selfMsgColor = Color 7710 37008 65535++-- | Server message color.+serverMsgColor :: Color+serverMsgColor = Color 30000 30000 0++-- | Other message color.+otherMsgColor :: Color+otherMsgColor = Color 0 0 0++-- | Join message color.+joinMsgColor :: Color+joinMsgColor = Color 12850 52685 12850 ++-- | Quit message color.+quitMsgColor :: Color+quitMsgColor = Color 52685 14135 0++-- | Part message color.+partMsgColor :: Color+partMsgColor = Color 52685 14135 0++-- | Action message color.+actionMsgColor :: Color+actionMsgColor = Color 41120 8224 61680++-- | Url color.+urlColor :: Color+urlColor = Color 38036 0 54227++-- | The column limit to wrap irc message.+wrapColumn :: Int+wrapColumn = 100++-- | Time stamp position.+timeStampPosition :: TextWindowType+timeStampPosition = TextWindowLeft++-- | Target language to translate.+targetLanguage :: Language+targetLanguage = English++-- | Source language.+sourceLanguage :: Language+sourceLanguage = ChineseSimplified++-- | Show line number.+showLineNumber :: Bool+showLineNumber = False++-- | Default user nick.+defaultNick :: String+defaultNick = "manateeUser"++-- | Default server.+defaultServer :: String+defaultServer = "irc.freenode.net"++-- | Default port.+defaultPort :: Int+defaultPort = 6667++-- | Default channel+defaultChannel :: String+defaultChannel = "#haskell"
+ Config/Import.hs view
@@ -0,0 +1,21 @@+-- Author: Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved.+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Config.Import (actionMsgColor, joinMsgColor, otherMsgColor, partMsgColor, quitMsgColor, selfMsgColor, serverMsgColor, urlColor, wrapColumn, timeStampPosition, sourceLanguage, targetLanguage, showLineNumber, defaultNick, defaultServer, defaultPort, defaultChannel) where ++import Config.Default
+ Config/IrcClient.hs view
@@ -0,0 +1,91 @@+-- Author: Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved.+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Config.User where++import Graphics.UI.Gtk.Gdk.GC (Color (..))+import Graphics.UI.Gtk.General.Enums (TextWindowType (..))+import Language.Translate.Google++-- | Self message color.+selfMsgColor :: Color+selfMsgColor = Color 7710 37008 65535++-- | Server message color.+serverMsgColor :: Color+serverMsgColor = Color 30000 30000 0++-- | Other message color.+otherMsgColor :: Color+otherMsgColor = Color 0 0 0++-- | Join message color.+joinMsgColor :: Color+joinMsgColor = Color 12850 52685 12850 ++-- | Quit message color.+quitMsgColor :: Color+quitMsgColor = Color 52685 14135 0++-- | Part message color.+partMsgColor :: Color+partMsgColor = Color 52685 14135 0++-- | Action message color.+actionMsgColor :: Color+actionMsgColor = Color 41120 8224 61680++-- | Url color.+urlColor :: Color+urlColor = Color 38036 0 54227++-- | The column limit to wrap irc message.+wrapColumn :: Int+wrapColumn = 100++-- | Time stamp position.+timeStampPosition :: TextWindowType+timeStampPosition = TextWindowLeft++-- | Target language to translate.+targetLanguage :: Language+targetLanguage = English++-- | Source language.+sourceLanguage :: Language+sourceLanguage = ChineseSimplified++-- | Show line number.+showLineNumber :: Bool+showLineNumber = False++-- | Default user nick.+defaultNick :: String+defaultNick = "manateeUser"++-- | Default server.+defaultServer :: String+defaultServer = "irc.freenode.net"++-- | Default port.+defaultPort :: Int+defaultPort = 6667++-- | Default channel+defaultChannel :: String+defaultChannel = "#haskell"
+ Config/User.hs view
@@ -0,0 +1,19 @@+-- Author: Andy Stewart <lazycat.manatee@gmail.com>+-- Maintainer: Andy Stewart <lazycat.manatee@gmail.com>+-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved.+-- +-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- any later version.+-- +-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+-- +-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Config.User where
Main.hs view
@@ -24,9 +24,13 @@ import Manatee.Core.Render import Manatee.Core.Types import Manatee.Extension.IrcClient+import Manatee.Extension.IrcClient.Types -- | Irc client render process. main :: IO () main = - startupRender (\ pagePath options client pageId -> - PageBufferWrap <$> ircBufferNew pagePath options client pageId)+ startupRender + (\ pagePath options client pageId customize -> + PageBufferWrap <$> ircBufferNew pagePath options client pageId customize)+ ircCustomizeNew+
Manatee/Extension/IrcClient/Daemon.hs view
@@ -235,13 +235,11 @@ -- putStrLn $ "ircListenServerMessage : Pong server " ++ show (showCommand command) hPutCommand handle $ PongCmd server str JoinCmd channels -> - when enableJoinMessage $ mapM_ (\ (channel, _) -> sendToChannel command channelMap channel $ \processId -> mkIrcClientSignal client processId ReceiveJoin (ReceiveJoinArgs nick user host) ) $ M.toList channels QuitCmd reason -> - when enableQuitMessage $ -- Broadcast quit message to all channel process. mapM_ (\ (_, processIdList) -> forM_ processIdList $ \processId ->
Manatee/Extension/IrcClient/IrcBuffer.hs view
@@ -20,6 +20,8 @@ {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Manatee.Extension.IrcClient.IrcBuffer where +import Config.Import+import Control.Applicative import Control.Concurrent.STM import Control.Monad import DBus.Client hiding (Signal)@@ -33,6 +35,7 @@ import Graphics.UI.Gtk.SourceView.SourceBuffer import Language.Translate.Google import Manatee.Core.DBus+import Manatee.Core.Dynload import Manatee.Core.Types import Manatee.Extension.IrcClient.DBus import Manatee.Extension.IrcClient.HighlightNick@@ -73,14 +76,6 @@ ,ircBufferScrollMark :: TVar (Maybe TextMark) ,ircBufferEditableTag :: TextTag ,ircBufferMessageTag :: TextTag- ,ircBufferServerColorTag :: TextTag- ,ircBufferSelfColorTag :: TextTag- ,ircBufferOtherColorTag :: TextTag- ,ircBufferJoinColorTag :: TextTag- ,ircBufferQuitColorTag :: TextTag- ,ircBufferPartColorTag :: TextTag- ,ircBufferActionColorTag :: TextTag- ,ircBufferUrlColorTag :: TextTag ,ircBufferTimeStamp :: TVar (Map Int (String, Color)) ,ircBufferNick :: TVar Nick ,ircBufferNickSet :: TVar (Set NickName)@@ -88,6 +83,7 @@ ,ircBufferTranslateLanguage :: TVar Language ,ircBufferBroadcastChannel :: TChan IrcBufferSignal ,ircBufferSmilePixbufs :: Map String Pixbuf+ ,ircBufferCustomize :: IrcCustomize } deriving Typeable @@ -96,10 +92,13 @@ deriving (Show, Eq, Ord) -- | Create buffer new.-ircBufferNew :: String -> [String] -> Client -> PageId -> IO IrcBuffer-ircBufferNew info _ client pageId = do+ircBufferNew :: String -> [String] -> Client -> PageId -> CustomizeWrap -> IO IrcBuffer+ircBufferNew info _ client pageId c = do+ -- Get customize option.+ let customize = castCustomize c+ -- Get server port channel information.- let (mynick, server, port, channel) = ircParseInfo info+ (mynick, server, port, channel) <- ircParseInfo info customize putStrLn ("Buffer create (server, port, channel) : " ++ show (server, port, channel)) -- Create source buffer and text mark.@@ -121,14 +120,15 @@ textTagTableAdd tagTable messageTag -- Create color tag.- serverColorTag <- ircBufferCreateColorTag sourceBuffer serverMsgColor- selfColorTag <- ircBufferCreateColorTag sourceBuffer selfMsgColor- otherColorTag <- ircBufferCreateColorTag sourceBuffer otherMsgColor- joinColorTag <- ircBufferCreateColorTag sourceBuffer joinMsgColor- quitColorTag <- ircBufferCreateColorTag sourceBuffer quitMsgColor- partColorTag <- ircBufferCreateColorTag sourceBuffer partMsgColor- actionColorTag <- ircBufferCreateColorTag sourceBuffer actionMsgColor- urlColorTag <- ircBufferCreateColorTag sourceBuffer urlColor+ ircBufferAddColorTag sourceBuffer (ircCustomizeServerColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizeSelfColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizeOtherColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizeJoinColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizeQuitColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizePartColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizeActionColorTag customize)+ ircBufferAddColorTag sourceBuffer (ircCustomizeUrlColorTag customize)+ let urlColorTag = ircCustomizeUrlColorTag customize set urlColorTag [textTagUnderline := UnderlineSingle] -- Open url when click.@@ -160,6 +160,7 @@ nickColorMap <- newTVarIO M.empty -- Target language.+ targetLanguage <- readTVarIO (ircCustomizeTargetLanguage customize) lang <- newTVarIO targetLanguage -- Broadcast channel.@@ -172,14 +173,14 @@ let buffer = IrcBuffer server port channel client pageId ircMode sourceBuffer insertMark promptMark scrollMark - textTag messageTag serverColorTag selfColorTag otherColorTag - joinColorTag quitColorTag partColorTag actionColorTag urlColorTag+ textTag messageTag timeStamp nick nickSet nickColorMap lang- broadcastChannel smilePixbufs+ broadcastChannel smilePixbufs customize -- Add self in nick map. ircBufferAddNick buffer (B.pack mynick) + -- Build DBus match rule. processId <- getProcessID mkIrcClientMatchRules client@@ -242,23 +243,33 @@ sourceBuffer `after` bufferChanged $ writeTChanIO broadcastChannel BufferChanged + return buffer -- | Parse "irc:[//[user@][server[:port]][/]][#channel]".-ircParseInfo :: String -> (Nick, Server, Port, Channel)-ircParseInfo str = - if null matchTextList- then (defaultNick, defaultServer, defaultPort, defaultChannel)- else - let (_ : (nickStr, _) : (serverStr, _) : (portStr, _) : (channelStr, _) : _) = elems $ head matchTextList- nick = if null nickStr then defaultNick else init nickStr- server = if null serverStr then defaultServer else serverStr- port = if null portStr then defaultPort else read $ tail portStr :: Int- channel = (\x -> case x of- ('/':c) -> c - _ -> x- ) $ if null channelStr then defaultChannel else channelStr- in (nick, server, port, channel)+ircParseInfo :: String -> IrcCustomize -> IO (Nick, Server, Port, Channel)+ircParseInfo str (IrcCustomize {ircCustomizeDefaultNick = nickTVar+ ,ircCustomizeDefaultServer = serverTVar+ ,ircCustomizeDefaultPort = portTVar+ ,ircCustomizeDefaultChannel = channelTVar+ }) = do+ defaultNick <- readTVarIO nickTVar+ defaultServer <- readTVarIO serverTVar+ defaultPort <- readTVarIO portTVar+ defaultChannel <- readTVarIO channelTVar+ return $ + if null matchTextList+ then (defaultNick, defaultServer, defaultPort, defaultChannel)+ else + let (_ : (nickStr, _) : (serverStr, _) : (portStr, _) : (channelStr, _) : _) = elems $ head matchTextList+ nick = if null nickStr then defaultNick else init nickStr+ server = if null serverStr then defaultServer else serverStr+ port = if null portStr then defaultPort else read $ tail portStr :: Int+ channel = (\x -> case x of+ ('/':c) -> c + _ -> x+ ) $ if null channelStr then defaultChannel else channelStr+ in (nick, server, port, channel) where matchTextList = matchAllText (makeRegex ("irc://([^<> \t\n'@:]+@)*([a-zA-Z.]+)*(:[0-9]+)*(/*[$#+!].[^ \t\n,]+)*" :: String) :: Regex) @@ -269,23 +280,27 @@ ircBufferReceivePrivate :: IrcBuffer -> NickName -> CommandArg -> IO () ircBufferReceivePrivate buffer@(IrcBuffer {ircBufferClient = client ,ircBufferPageId = pageId- ,ircBufferSelfColorTag = selfColorTag- ,ircBufferOtherColorTag = otherColorTag- ,ircBufferActionColorTag = actionColorTag+ ,ircBufferCustomize = + IrcCustomize + {ircCustomizeSelfColorTag = selfColorTag+ ,ircCustomizeOtherColorTag = otherColorTag+ ,ircCustomizeActionColorTag = actionColorTag} ,ircBufferNick = mynick}) nick content = do -- Format private message.- let ((msg, msgHeadLen), isAction) = + ((msg, msgHeadLen), isAction) <- if B.pack "\SOHACTION " `B.isPrefixOf` content && B.pack "\SOH" `B.isSuffixOf` content- then + then do let prefixLen = B.length (B.pack "\SOHACTION ") suffixLen = B.length (B.pack "\SOH") takeLen = B.length content - prefixLen - suffixLen newContent = B.take takeLen $ B.drop prefixLen content- in (ircBufferIndentMessage newContent (B.concat ["* ", nick, " "]), True)- else - (ircBufferIndentMessage content (B.concat ["<", nick, "> "]), False)+ args <- ircBufferIndentMessage buffer newContent (B.concat ["* ", nick, " "])+ return (args, True)+ else do + args <- ircBufferIndentMessage buffer content (B.concat ["<", nick, "> "]) + return (args, False) -- Get color with the type of private message. mynickname <- readTVarIO mynick@@ -314,7 +329,9 @@ -- | Receive quit message. ircBufferReceiveQuit :: IrcBuffer -> NickName -> UserName -> HostName -> B.ByteString -> IO () ircBufferReceiveQuit buffer@(IrcBuffer {ircBufferNickSet = nickSet- ,ircBufferQuitColorTag = quitColorTag}) + ,ircBufferCustomize =+ IrcCustomize + {ircCustomizeQuitColorTag = quitColorTag}}) nick user host reason = do -- Quit nick map. set <- readTVarIO nickSet@@ -327,7 +344,7 @@ -- Format quit message. let adjustMsg = B.pack "*** " content = B.concat [nick, " (", user, "@", host, ") has quit: ", reason]- (msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg+ (msg, msgHeadLen) <- ircBufferIndentMessage buffer content adjustMsg -- Insert quit message. ircBufferReceiveMsg buffer msg msgHeadLen quitColorTag@@ -336,7 +353,9 @@ -- | Receive part message. ircBufferReceivePart :: IrcBuffer -> NickName -> UserName -> HostName -> B.ByteString -> IO () ircBufferReceivePart buffer@(IrcBuffer {ircBufferNickSet = nickSet- ,ircBufferPartColorTag = partColorTag}) + ,ircBufferCustomize =+ IrcCustomize + {ircCustomizePartColorTag = partColorTag}}) nick user host reason = do -- Remove from set. modifyTVarIO nickSet $ \ set ->@@ -345,7 +364,7 @@ -- Format part message. let adjustMsg = B.pack "*** " content = B.concat [nick, " (", user, "@", host, ") has part: ", reason]- (msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg+ (msg, msgHeadLen) <- ircBufferIndentMessage buffer content adjustMsg -- Insert part message. ircBufferReceiveMsg buffer msg msgHeadLen partColorTag@@ -360,12 +379,14 @@ -- | Receive topic replay message. ircBufferReceiveChannelUrl :: IrcBuffer -> B.ByteString -> IO () ircBufferReceiveChannelUrl buffer@(IrcBuffer {ircBufferChannel = channel- ,ircBufferServerColorTag = serverColorTag})+ ,ircBufferCustomize =+ IrcCustomize + {ircCustomizeServerColorTag = serverColorTag}}) url = do -- Format channel url message. let adjustMsg = B.pack "*** " content = B.concat [B.pack channel, " URL: ", url]- (msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg+ (msg, msgHeadLen) <- ircBufferIndentMessage buffer content adjustMsg -- Insert channel url message. ircBufferReceiveMsg buffer msg msgHeadLen serverColorTag@@ -373,12 +394,14 @@ -- | Receive topic replay message. ircBufferReceiveTopicReply :: IrcBuffer -> CommandArg -> IO () ircBufferReceiveTopicReply buffer@(IrcBuffer {ircBufferChannel = channel- ,ircBufferServerColorTag = serverColorTag})+ ,ircBufferCustomize =+ IrcCustomize + {ircCustomizeServerColorTag = serverColorTag}}) message = do -- Format topic replay message. let adjustMsg = B.pack "*** " content = B.concat ["Topic for ", B.pack channel, ": ", message]- (msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg+ (msg, msgHeadLen) <- ircBufferIndentMessage buffer content adjustMsg -- Insert topic replay message. ircBufferReceiveMsg buffer msg msgHeadLen serverColorTag@@ -386,13 +409,15 @@ -- | Receive topic replay message. ircBufferReceiveTopicWhoTime :: IrcBuffer -> NickName -> Integer -> IO () ircBufferReceiveTopicWhoTime buffer@(IrcBuffer {ircBufferChannel = channel- ,ircBufferServerColorTag = serverColorTag})+ ,ircBufferCustomize =+ IrcCustomize + {ircCustomizeServerColorTag = serverColorTag}}) nick seconds = do -- Format topic who time message. time <- getSecondsTimeStamp seconds "%H:%M:%S %Y/%m/%d" let adjustMsg = B.pack "*** " content = B.concat [B.pack channel, ": topic set by ", nick, ", ", B.pack time]- (msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg+ (msg, msgHeadLen) <- ircBufferIndentMessage buffer content adjustMsg -- Insert topic who time message. ircBufferReceiveMsg buffer msg msgHeadLen serverColorTag@@ -400,8 +425,11 @@ -- | Receive join message. ircBufferReceiveJoin :: IrcBuffer -> NickName -> UserName -> HostName -> IO () ircBufferReceiveJoin buffer@(IrcBuffer {ircBufferChannel = channel- ,ircBufferJoinColorTag = joinColorTag- ,ircBufferNick = mynick}) + ,ircBufferNick = mynick+ ,ircBufferCustomize =+ IrcCustomize + {ircCustomizeJoinColorTag = joinColorTag}+ }) nick user host = do nickname <- readTVarIO mynick -- Don't print self join message.@@ -412,7 +440,7 @@ -- Format join message. let adjustMsg = B.pack "*** " content = B.concat [nick, " (", user, "@", host, ") has joined channel ", B.pack channel]- (msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg + (msg, msgHeadLen) <- ircBufferIndentMessage buffer content adjustMsg -- Insert join message. ircBufferReceiveMsg buffer msg msgHeadLen joinColorTag@@ -426,8 +454,10 @@ ,ircBufferMessageTag = messageTag ,ircBufferTimeStamp = stamp ,ircBufferNickColorMap = nickColorMap- ,ircBufferUrlColorTag = urlColorTag ,ircBufferSmilePixbufs = smilePixbufs+ ,ircBufferCustomize =+ IrcCustomize + {ircCustomizeUrlColorTag = urlColorTag} } message msgHeadLen colorTag = do -- Make editable tag can edit temporary for insert irc message.@@ -555,16 +585,13 @@ -- Update color map. modifyTVarIO nickColorMap $ \map -> M.insert nick textTag map- --- | Create color tag.-ircBufferCreateColorTag :: TextBufferClass buffer => buffer -> Color -> IO TextTag-ircBufferCreateColorTag buffer color = do++-- | Add color tag.+ircBufferAddColorTag :: TextBufferClass buffer => buffer -> TextTag -> IO ()+ircBufferAddColorTag buffer colorTag = do tagTable <- textBufferGetTagTable buffer- colorTag <- textTagNew Nothing- set colorTag [textTagForegroundGdk := color] textTagTableAdd tagTable colorTag- return colorTag-+ -- | Insert prompt string. ircBufferInsertPromptStr :: TextBufferClass buffer => buffer -> IO () ircBufferInsertPromptStr buffer = @@ -583,12 +610,52 @@ textBufferCreateMark buffer Nothing textIter True -- | Indent message.-ircBufferIndentMessage :: B.ByteString -> B.ByteString -> (B.ByteString, Int)-ircBufferIndentMessage content adjustMsg = (concatMsg msgLines, B.length adjustMsg)- where indentMsg = B.replicate (B.length adjustMsg) ' '- msgLines = map B.unwords $ wrapLine (wrapColumn - B.length adjustMsg) (splitWords content)- concatMsg [] = B.concat [adjustMsg, "\n"]- concatMsg [x] = B.concat [adjustMsg, x, "\n"]- concatMsg (x:xs) = B.concat [B.concat [adjustMsg, x, "\n"]- ,B.concat $ map (\ xx -> B.concat [indentMsg, xx, "\n"]) xs]+ircBufferIndentMessage :: IrcBuffer -> B.ByteString -> B.ByteString -> IO (B.ByteString, Int)+ircBufferIndentMessage buffer content adjustMsg = do+ wrapColumn <- readTVarIO (ircCustomizeWrapColumn $ ircBufferCustomize buffer) + let indentMsg = B.replicate (B.length adjustMsg) ' '+ msgLines = map B.unwords $ wrapLine (wrapColumn - B.length adjustMsg) (splitWords content)+ concatMsg [] = B.concat [adjustMsg, "\n"]+ concatMsg [x] = B.concat [adjustMsg, x, "\n"]+ concatMsg (x:xs) = B.concat [B.concat [adjustMsg, x, "\n"]+ ,B.concat $ map (\ xx -> B.concat [indentMsg, xx, "\n"]) xs]++ return (concatMsg msgLines, B.length adjustMsg)++-- | Irc customize new.+ircCustomizeNew :: IO CustomizeWrap+ircCustomizeNew =+ fmap CustomizeWrap $ + IrcCustomize <$> newTVarIO selfMsgColor+ <*> newTVarIO serverMsgColor+ <*> newTVarIO otherMsgColor+ <*> newTVarIO joinMsgColor+ <*> newTVarIO quitMsgColor+ <*> newTVarIO partMsgColor+ <*> newTVarIO actionMsgColor+ <*> newTVarIO urlColor+ <*> newTVarIO wrapColumn+ <*> ircColorTagNew serverMsgColor+ <*> ircColorTagNew selfMsgColor+ <*> ircColorTagNew otherMsgColor+ <*> ircColorTagNew joinMsgColor+ <*> ircColorTagNew quitMsgColor+ <*> ircColorTagNew partMsgColor+ <*> ircColorTagNew actionMsgColor+ <*> ircColorTagNew urlColor+ <*> newTVarIO timeStampPosition+ <*> newTVarIO sourceLanguage+ <*> newTVarIO targetLanguage+ <*> newTVarIO showLineNumber+ <*> newTVarIO defaultNick+ <*> newTVarIO defaultServer+ <*> newTVarIO defaultPort+ <*> newTVarIO defaultChannel++-- | New color tag.+ircColorTagNew :: Color -> IO TextTag+ircColorTagNew color = do+ colorTag <- textTagNew Nothing+ set colorTag [textTagForegroundGdk := color]+ return colorTag
Manatee/Extension/IrcClient/IrcView.hs view
@@ -50,6 +50,8 @@ import Manatee.Toolkit.Gtk.Multiline import Manatee.Toolkit.Gtk.ScrolledWindow import Network.FastIRC.Messages+import Paths_manatee_ircclient+import System.FilePath import Text.Morse import qualified Data.ByteString.Char8 as B@@ -72,6 +74,7 @@ pageBufferClient = ircBufferClient pageBufferCreateView a pId = PageViewWrap <$> ircViewNew a pId pageBufferMode = ircBufferMode+ pageBufferPackageName _ = fmap takeFileName getDataDir instance PageView IrcView where pageViewBuffer = PageBufferWrap . ircViewBuffer@@ -108,17 +111,19 @@ let sv = IrcView pId scrolledWindow ircView sb channel -- Customize setup.- sourceViewSetHighlightCurrentLine ircView True -- highlight current line.- sourceViewSetInsertSpacesInsteadOfTabs ircView True -- use space instead tabs- sourceViewSetShowLineNumbers ircView showLineNumber -- show line number- textViewSetCursorVisible ircView True -- make cursor visible- textViewSetWrapMode ircView WrapWord -- auto wrap text+ sourceViewSetHighlightCurrentLine ircView True -- highlight current line.+ sourceViewSetInsertSpacesInsteadOfTabs ircView True -- use space instead tabs+ set ircView -- show line number+ [sourceViewShowLineNumbers :=> readTVarIO (ircCustomizeShowLineNumber $ ircBufferCustomize sb)]+ textViewSetCursorVisible ircView True -- make cursor visible+ textViewSetWrapMode ircView WrapWord -- auto wrap text -- Set fixed-width font, otherwise wrap mode can't work. fontDescr <- fontDescriptionFromString "Monospace" widgetModifyFont ircView (Just fontDescr) -- Update time stamp at right.+ timeStampPosition <- readTVarIO (ircCustomizeTimeStampPosition $ ircBufferCustomize sb) gutter <- sourceViewGetGutter ircView timeStampPosition cell <- cellRendererTextNew sourceGutterInsert gutter cell 0@@ -171,6 +176,9 @@ ircViewSwitchTranslateLanguage :: IrcView -> IO () ircViewSwitchTranslateLanguage IrcView {ircViewBuffer = buffer ,ircViewBroadcastChannel = channel} = do+ let customize = ircBufferCustomize buffer + targetLanguage <- readTVarIO (ircCustomizeTargetLanguage customize)+ sourceLanguage <- readTVarIO (ircCustomizeSourceLanguage customize) modifyTVarIO (ircBufferTranslateLanguage buffer) $ \lang -> if lang == targetLanguage then sourceLanguage@@ -399,7 +407,10 @@ -- | Set selection mark. ircViewToggleSelectionMark :: IrcView -> IO ()-ircViewToggleSelectionMark = textViewToggleSelectionMark . ircViewView +ircViewToggleSelectionMark view = + ifM (textViewToggleSelectionMark $ ircViewView view)+ (pageViewUpdateInfoStatus view "Selection" "Selection (Active)")+ (pageViewUpdateInfoStatus view "Selection" "Selection (Inactive)") -- | Exchange selection mark. ircViewExchangeSelectionMark :: IrcView -> IO ()@@ -466,16 +477,16 @@ -- | Open url around pointer. ircViewOpenUrl :: IrcView -> IO () ircViewOpenUrl view@(IrcView {ircViewBuffer = buffer}) = - textBufferGetTagText (ircBufferBuffer buffer) (ircBufferUrlColorTag buffer)+ textBufferGetTagText (ircBufferBuffer buffer) (ircCustomizeUrlColorTag $ ircBufferCustomize buffer) >?>= \ url -> mkDaemonSignal (pageViewClient view) NewTab (NewTabArgs "PageBrowser" url []) -- | Translate message around pointer. ircViewTranslateMessage :: IrcView -> IO () ircViewTranslateMessage view@(IrcView {ircViewBuffer = - IrcBuffer {ircBufferBuffer = buffer- ,ircBufferMessageTag = messageTag- ,ircBufferTranslateLanguage = language}}) = do+ ircBuffer@(IrcBuffer {ircBufferBuffer = buffer+ ,ircBufferMessageTag = messageTag+ ,ircBufferTranslateLanguage = language})}) = do -- Use end line iter to match messageTag content (skip message head). iter <- textBufferGetCurrentLineEndIter_ buffer textIterBackwardChar iter@@ -485,6 +496,9 @@ pageViewUpdateOutputStatus view "Fetch translation ..." Nothing -- Translate reverse. :) lang <- readTVarIO language+ let customize = ircBufferCustomize ircBuffer+ targetLanguage <- readTVarIO (ircCustomizeTargetLanguage customize)+ sourceLanguage <- readTVarIO (ircCustomizeSourceLanguage customize) translate text Nothing (if lang == targetLanguage then sourceLanguage else targetLanguage))
Manatee/Extension/IrcClient/Smile.hs view
@@ -95,7 +95,7 @@ createSmilePixbufs :: IO (Map String Pixbuf) createSmilePixbufs = do dir <- getDataDir- let imagePath imageName = dir </> (imageName ++ ".png")+ let imagePath imageName = dir </> "icons" </> (imageName ++ ".png") paths = map (second imagePath) [("x(", "angry") ,(":/", "confused")
Manatee/Extension/IrcClient/Types.hs view
@@ -18,10 +18,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-} module Manatee.Extension.IrcClient.Types where +import Control.Concurrent.STM+import Data.Typeable+import GHC import Graphics.UI.Gtk hiding (Statusbar, statusbarNew, get, Language) import Language.Translate.Google+import Manatee.Core.Types+import Manatee.Toolkit.General.STM+import Unsafe.Coerce import qualified Data.ByteString.Char8 as B @@ -31,102 +38,95 @@ type Nick = String type Password = String +data IrcCustomize = + IrcCustomize {ircCustomizeSelfMsgColor :: TVar Color+ ,ircCustomizeServerMsgColor :: TVar Color+ ,ircCustomizeOtherMsgColor :: TVar Color+ ,ircCustomizeJoinMsgColor :: TVar Color+ ,ircCustomizeQuitMsgColor :: TVar Color+ ,ircCustomizePartMsgColor :: TVar Color+ ,ircCustomizeActionMsgColor :: TVar Color+ ,ircCustomizeUrlColor :: TVar Color+ ,ircCustomizeWrapColumn :: TVar Int+ ,ircCustomizeServerColorTag :: TextTag+ ,ircCustomizeSelfColorTag :: TextTag+ ,ircCustomizeOtherColorTag :: TextTag+ ,ircCustomizeJoinColorTag :: TextTag+ ,ircCustomizeQuitColorTag :: TextTag+ ,ircCustomizePartColorTag :: TextTag+ ,ircCustomizeActionColorTag :: TextTag+ ,ircCustomizeUrlColorTag :: TextTag+ ,ircCustomizeTimeStampPosition :: TVar TextWindowType+ ,ircCustomizeSourceLanguage :: TVar Language+ ,ircCustomizeTargetLanguage :: TVar Language+ ,ircCustomizeShowLineNumber :: TVar Bool+ ,ircCustomizeDefaultNick :: TVar String+ ,ircCustomizeDefaultServer :: TVar String+ ,ircCustomizeDefaultPort :: TVar Int+ ,ircCustomizeDefaultChannel :: TVar String+ }+ deriving Typeable++instance Customize IrcCustomize where+ customizeConfigFile _ = "IrcClient.hs"+ customizeLoad a = + [("selfMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeSelfMsgColor a) (ircCustomizeSelfColorTag a))+ ,("serverMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeServerMsgColor a) (ircCustomizeServerColorTag a))+ ,("otherMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeOtherMsgColor a) (ircCustomizeOtherColorTag a))+ ,("joinMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeJoinMsgColor a) (ircCustomizeJoinColorTag a))+ ,("quitMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeQuitMsgColor a) (ircCustomizeQuitColorTag a))+ ,("partMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizePartMsgColor a) (ircCustomizePartColorTag a))+ ,("actionMsgColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeActionMsgColor a) (ircCustomizeActionColorTag a))+ ,("urlColor"+ ,\ v -> ircUpdateColorTag v (ircCustomizeUrlColor a) (ircCustomizeUrlColorTag a))+ ,("wrapColumn"+ ,\ v -> writeTVarIO (ircCustomizeWrapColumn a) (unsafeCoerce v :: Int))+ ,("timeStampPosition"+ ,\ v -> writeTVarIO (ircCustomizeTimeStampPosition a) (unsafeCoerce v :: TextWindowType))+ ,("sourceLanguage"+ ,\ v -> writeTVarIO (ircCustomizeSourceLanguage a) (unsafeCoerce v :: Language))+ ,("targetLanguage"+ ,\ v -> writeTVarIO (ircCustomizeTargetLanguage a) (unsafeCoerce v :: Language))+ ,("showLineNumber"+ ,\ v -> writeTVarIO (ircCustomizeShowLineNumber a) (unsafeCoerce v :: Bool))+ ,("defaultNick"+ ,\ v -> writeTVarIO (ircCustomizeDefaultNick a) (unsafeCoerce v :: String))+ ,("defaultServer"+ ,\ v -> writeTVarIO (ircCustomizeDefaultServer a) (unsafeCoerce v :: String))+ ,("defaultPort"+ ,\ v -> writeTVarIO (ircCustomizeDefaultPort a) (unsafeCoerce v :: Int))+ ,("defaultChannel"+ ,\ v -> writeTVarIO (ircCustomizeDefaultChannel a) (unsafeCoerce v :: String))+ ]++-- | Update color tag.+ircUpdateColorTag :: HValue -> TVar Color -> TextTag -> IO ()+ircUpdateColorTag hvalue colorTVar colorTag = do+ let color = unsafeCoerce hvalue :: Color+ writeTVarIO colorTVar color+ set colorTag [textTagForegroundGdk := color]+ -- | Temporary user name for test. tempUser :: B.ByteString tempUser = "Irc client for Manatee ( http://www.flickr.com/photos/48809572@N02/ )." -- | Temporary real name for test. tempRealname :: B.ByteString-tempRealname = "Andy Stewart"---- | Default user nick.-defaultNick :: String-defaultNick = "manateeUser"---- | Default server.-defaultServer :: String-defaultServer = "irc.freenode.net"---- | Default port.-defaultPort :: Int-defaultPort = 6667---- | Default channel-defaultChannel :: String-defaultChannel = "#haskell"---- | Enable join message.-enableJoinMessage :: Bool-enableJoinMessage = True---- | Enable quit message.-enableQuitMessage :: Bool-enableQuitMessage = True---- | Target language to translate.-targetLanguage :: Language-targetLanguage = English---- | Source language.-sourceLanguage :: Language-sourceLanguage = ChineseSimplified---- | Show line number.-showLineNumber :: Bool-showLineNumber = False---- | Time stamp position.-timeStampPosition :: TextWindowType-timeStampPosition = TextWindowLeft+tempRealname = "Manatee User" -- | The prompt string. promptStr :: String promptStr = "> " --- | The column limit to wrap irc message.-wrapColumn :: Int-wrapColumn = 100- -- | The default time stamp : [00:00:00] defaultTimeStamp :: String defaultTimeStamp = " "---- | Server message color.-serverMsgColor :: Color-serverMsgColor = Color 30000 30000 0---- | Self message color.-selfMsgColor :: Color-selfMsgColor = Color 7710 37008 65535--- selfMsgColor = Color 12850 52685 12850---- | Other message color.-otherMsgColor :: Color-otherMsgColor = Color 0 0 0--- otherMsgColor = Color 8738 35723 8738---- | Join message color.-joinMsgColor :: Color-joinMsgColor = Color 12850 52685 12850 --- joinMsgColor = Color 26985 26985 26985---- | Quit message color.-quitMsgColor :: Color-quitMsgColor = Color 52685 14135 0--- quitMsgColor = Color 26985 26985 26985---- | Part message color.-partMsgColor :: Color-partMsgColor = Color 52685 14135 0--- partMsgColor = Color 26985 26985 26985---- | Action message color.-actionMsgColor :: Color-actionMsgColor = Color 41120 8224 61680--- actionMsgColor = Color 48830 48830 48830---- | Url color.-urlColor :: Color-urlColor = Color 38036 0 54227
Setup.hs view
@@ -16,8 +16,10 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. +import Distribution.PackageDescription import Distribution.Simple import Manatee.Core.Config+import Manatee.Core.Dynload import Manatee.Core.Types import Manatee.Extension.IrcClient.PageMode @@ -25,8 +27,20 @@ main = defaultMainWithHooks simpleUserHooks {+ -- Generate User.hs and Import.hs before configure.+ preConf = \ _ _ -> do+ generateConfig "IrcClient.hs"+ ["actionMsgColor","joinMsgColor","otherMsgColor"+ ,"partMsgColor","quitMsgColor","selfMsgColor"+ ,"serverMsgColor","urlColor","wrapColumn"+ ,"timeStampPosition", "sourceLanguage", "targetLanguage"+ ,"showLineNumber"+ ,"defaultNick", "defaultServer", "defaultPort", "defaultChannel"+ ]+ + return emptyHookedBuildInfo -- Update PageTypeRule after install successful.- postInst = \ _ _ _ _ -> do+ ,postInst = \ _ _ _ _ -> do (PageTypeRule rule) <- readConfig pageTypeRulePath (PageTypeRule M.empty) writeConfig pageTypeRulePath (PageTypeRule (M.insert "PageIrc" "manatee-ircclient" rule)) -- Update PageModeRule.@@ -38,3 +52,4 @@ writeConfig extensionGlobalKeymapPath (ExtensionGloalKeymap (M.insert "F6" ("PageIrc", "irc://", []) keymap)) }+
manatee-ircclient.cabal view
@@ -1,5 +1,5 @@ name: manatee-ircclient-version: 0.0.6+version: 0.0.7 Cabal-Version: >= 1.6 license: GPL-3 license-file: LICENSE@@ -7,8 +7,12 @@ synopsis: IRC client extension for Manatee. description: manatee-ircclient is IRC client extension for Manatee (Haskell/Gtk+ Integrated Live Environment) .- Video at (Select 720p HD) at : <http://www.youtube.com/watch?v=weS6zys3U8k> <http://v.youku.com/v_show/id_XMjI2MDMzODI4.html>+ Default configuration template at Config\/IrcClient.hs, copy to directory `HOME/.manatee/config/`. .+ Note, you need re-install package to start the configuration file take effect the next time,+ .+ Video at (Select 720p HD) at : <http://www.youtube.com/watch?v=weS6zys3U8k> <http://www.youtube.com/watch?v=A3DgKDVkyeM> <http://v.youku.com/v_show/id_XMjI2MDMzODI4.html>+ . Screenshots at : <http://goo.gl/MkVw> . Manual at : <http://haskell.org/haskellwiki/Manatee>@@ -25,35 +29,37 @@ tested-with: GHC==6.12.3 build-type: Custom -data-dir: icons-data-files: angry.png- confused.png- crying.png- embarrassed.png- inlove.png- kiss.png- sleepy.png- sad.png- laugh.png- smile.png- surprised.png- tired.png- tongue.png- whistling.png- wink.png+data-dir: ""+data-files: icons/angry.png+ icons/confused.png+ icons/crying.png+ icons/embarrassed.png+ icons/inlove.png+ icons/kiss.png+ icons/sleepy.png+ icons/sad.png+ icons/laugh.png+ icons/smile.png+ icons/surprised.png+ icons/tired.png+ icons/tongue.png+ icons/whistling.png+ icons/wink.png+ + Config/IrcClient.hs Source-Repository head type: darcs location: http://patch-tag.com/r/AndyStewart/manatee-ircclient Library- build-depends: base >= 4 && < 5, manatee-core >= 0.0.6, dbus-client >= 0.3 && < 0.4, stm >= 2.1.2.0,+ build-depends: base >= 4 && < 5, manatee-core >= 0.0.7, dbus-client >= 0.3 && < 0.4, stm >= 2.1.2.0, containers >= 0.3.0.0, gtk-serialized-event >= 0.12.0, gtk >= 0.12.0, text >= 0.7.1.0, bytestring >= 0.9.1.5, dbus-core, template-haskell, gtksourceview2 >= 0.12.0, unix >= 2.4.0.0, network, groom, fastirc >= 0.2.0, split >= 0.1.2, nano-md5 >= 0.1.2, filepath, regex-posix >= 0.94.1, array >= 0.3.0.0, GoogleTranslate >= 0.0.3, utf8-string, mtl, Cabal, - MorseCode >= 0.0.4+ MorseCode >= 0.0.4, ghc exposed-modules: Manatee.Extension.IrcClient Manatee.Extension.IrcClient.Types@@ -64,7 +70,11 @@ Manatee.Extension.IrcClient.IrcView Manatee.Extension.IrcClient.PageMode Manatee.Extension.IrcClient.Smile- other-modules: Paths_manatee_ircclient+ other-modules: + Paths_manatee_ircclient+ Config.Default+ Config.User+ Config.Import extensions: ghc-options: -fwarn-unused-matches -fwarn-unused-binds -fwarn-unused-imports -fwarn-overlapping-patterns -fwarn-duplicate-exports -fwarn-unrecognised-pragmas -fwarn-hi-shadowing