diff --git a/Config/Default.hs b/Config/Default.hs new file mode 100644 --- /dev/null +++ b/Config/Default.hs @@ -0,0 +1,91 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- 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 . + +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" diff --git a/Config/Import.hs b/Config/Import.hs new file mode 100644 --- /dev/null +++ b/Config/Import.hs @@ -0,0 +1,21 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- 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 . + +module Config.Import (actionMsgColor, joinMsgColor, otherMsgColor, partMsgColor, quitMsgColor, selfMsgColor, serverMsgColor, urlColor, wrapColumn, timeStampPosition, sourceLanguage, targetLanguage, showLineNumber, defaultNick, defaultServer, defaultPort, defaultChannel) where + +import Config.Default diff --git a/Config/IrcClient.hs b/Config/IrcClient.hs new file mode 100644 --- /dev/null +++ b/Config/IrcClient.hs @@ -0,0 +1,91 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- 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 . + +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" diff --git a/Config/User.hs b/Config/User.hs new file mode 100644 --- /dev/null +++ b/Config/User.hs @@ -0,0 +1,19 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- 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 . + +module Config.User where diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 + diff --git a/Manatee/Extension/IrcClient/Daemon.hs b/Manatee/Extension/IrcClient/Daemon.hs --- a/Manatee/Extension/IrcClient/Daemon.hs +++ b/Manatee/Extension/IrcClient/Daemon.hs @@ -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 -> diff --git a/Manatee/Extension/IrcClient/IrcBuffer.hs b/Manatee/Extension/IrcClient/IrcBuffer.hs --- a/Manatee/Extension/IrcClient/IrcBuffer.hs +++ b/Manatee/Extension/IrcClient/IrcBuffer.hs @@ -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 diff --git a/Manatee/Extension/IrcClient/IrcView.hs b/Manatee/Extension/IrcClient/IrcView.hs --- a/Manatee/Extension/IrcClient/IrcView.hs +++ b/Manatee/Extension/IrcClient/IrcView.hs @@ -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)) diff --git a/Manatee/Extension/IrcClient/Smile.hs b/Manatee/Extension/IrcClient/Smile.hs --- a/Manatee/Extension/IrcClient/Smile.hs +++ b/Manatee/Extension/IrcClient/Smile.hs @@ -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") diff --git a/Manatee/Extension/IrcClient/Types.hs b/Manatee/Extension/IrcClient/Types.hs --- a/Manatee/Extension/IrcClient/Types.hs +++ b/Manatee/Extension/IrcClient/Types.hs @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -16,8 +16,10 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . +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)) } + diff --git a/manatee-ircclient.cabal b/manatee-ircclient.cabal --- a/manatee-ircclient.cabal +++ b/manatee-ircclient.cabal @@ -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 : + 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 : + . Screenshots at : . Manual at : @@ -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