module Manatee.Extension.IrcClient.IrcView where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Data.Map (Map)
import Data.ByteString (ByteString)
import Data.Text.Lazy (Text)
import Data.Typeable
import Graphics.UI.Gtk hiding (Statusbar, statusbarNew, get, Language)
import Graphics.UI.Gtk.Gdk.SerializedEvent
import Graphics.UI.Gtk.SourceView
import Language.Translate.Google
import Manatee.Core.DBus
import Manatee.Core.PageView
import Manatee.Core.Types
import Manatee.Extension.IrcClient.DBus
import Manatee.Extension.IrcClient.HighlightNick
import Manatee.Extension.IrcClient.IrcBuffer
import Manatee.Extension.IrcClient.Types
import Manatee.Toolkit.General.Basic
import Manatee.Toolkit.General.ByteString
import Manatee.Toolkit.General.Map
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.Process
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.String
import Manatee.Toolkit.Gtk.Concurrent
import Manatee.Toolkit.Gtk.Gtk
import Manatee.Toolkit.Gtk.Multiline
import Manatee.Toolkit.Gtk.ScrolledWindow
import Network.FastIRC.Messages
import Text.Morse
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.ByteString.UTF8 as UTF8
data IrcView =
IrcView {ircViewPlugId :: TVar PagePlugId
,ircViewScrolledWindow :: ScrolledWindow
,ircViewView :: SourceView
,ircViewBuffer :: IrcBuffer
,ircViewBroadcastChannel :: ViewChannel IrcBufferSignal
}
deriving Typeable
instance PageBuffer IrcBuffer where
pageBufferGetName = return . ircBufferChannel
pageBufferSetName _ _ = return ()
pageBufferClient = ircBufferClient
pageBufferCreateView a pId = PageViewWrap <$> ircViewNew a pId
pageBufferMode = ircBufferMode
instance PageView IrcView where
pageViewBuffer = PageBufferWrap . ircViewBuffer
pageViewPlugId = ircViewPlugId
pageViewFocus = widgetGrabFocus . ircViewView
pageViewCut = ircViewCut
pageViewCopy = ircViewCopy
pageViewPaste = ircViewPaste
pageViewScrolledWindow = ircViewScrolledWindow
pageViewHandleKeyAction = ircViewHandleKeyAction
pageViewScrollToTop = ircViewScrollToTop
pageViewScrollToBottom = ircViewScrollToBottom
pageViewScrollVerticalPage = ircViewScrollVerticalPage
pageViewScrollVerticalStep = ircViewScrollVerticalStep
ircViewNew :: IrcBuffer -> PagePlugId -> IO IrcView
ircViewNew sb plugId = do
pId <- newTVarIO plugId
scrolledWindow <- scrolledWindowNew_
ircView <- sourceViewNewWithBuffer (ircBufferBuffer sb)
scrolledWindow `containerAdd` ircView
forM_ [StateNormal, StateActive, StatePrelight, StateSelected, StateInsensitive]
$ \state -> widgetModifyBg ircView state (nickColorToColor backgroundColor)
channel <- createViewChannel (ircBufferBroadcastChannel sb) ircView
let sv = IrcView pId scrolledWindow ircView sb channel
sourceViewSetHighlightCurrentLine ircView True
sourceViewSetInsertSpacesInsteadOfTabs ircView True
sourceViewSetShowLineNumbers ircView showLineNumber
textViewSetCursorVisible ircView True
textViewSetWrapMode ircView WrapWord
fontDescr <- fontDescriptionFromString "Monospace"
widgetModifyFont ircView (Just fontDescr)
gutter <- sourceViewGetGutter ircView timeStampPosition
cell <- cellRendererTextNew
sourceGutterInsert gutter cell 0
sourceGutterSetCellDataFunc gutter cell $ \ c l _ -> do
timeStampMap <- readTVarIO $ ircBufferTimeStamp sb
let (timeStamp, timeColor) =
case findMinMatch timeStampMap (\ line _ -> line == l) of
Just x -> snd x
Nothing -> (defaultTimeStamp, Color 0 0 0)
set (castToCellRendererText c) [cellText := timeStamp]
set (castToCellRendererText c) [cellTextForegroundColor := timeColor]
sourceGutterSetCellSizeFunc gutter cell $ \ c ->
set (castToCellRendererText c) [cellTextWidthChars := (1)]
ircViewListenChannel sv
return sv
ircViewListenChannel :: IrcView -> IO ()
ircViewListenChannel view =
listenViewChannel (ircViewBroadcastChannel view) $ \ signal ->
case signal of
SwitchTranslateLanguage -> do
lang <- readTVarIO $ ircBufferTranslateLanguage $ ircViewBuffer view
pageViewUpdateInfoStatus view "Translate" ("Translate to (" ++ show lang ++ ")")
BufferChanged -> do
let buffer = ircViewBuffer view
textBuffer = ircBufferBuffer buffer
ircView = ircViewView view
readTVarIO (ircBufferScrollMark buffer)
>?>= \ mark -> do
iter <- textBufferGetIterAtMark textBuffer mark
(y, _) <- textViewGetLineYrange ircView iter
(Rectangle _ vy _ vh) <- textViewGetVisibleRect ircView
when (y >= vy + vh) $
textViewScrollMarkOnscreen ircView mark
ircViewSwitchTranslateLanguage :: IrcView -> IO ()
ircViewSwitchTranslateLanguage IrcView {ircViewBuffer = buffer
,ircViewBroadcastChannel = channel} = do
modifyTVarIO (ircBufferTranslateLanguage buffer)
$ \lang -> if lang == targetLanguage
then sourceLanguage
else targetLanguage
writeTChanIO (viewChannel channel) SwitchTranslateLanguage
ircViewHandleKeyAction :: IrcView -> Text -> SerializedEvent -> IO ()
ircViewHandleKeyAction view keystoke sEvent =
case M.lookup keystoke ircViewKeymap of
Just action -> action view
Nothing -> widgetPropagateEvent (ircViewView view) sEvent
ircViewScrollToTop :: IrcView -> IO ()
ircViewScrollToTop a = do
textViewBegin (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewScrollToBottom :: IrcView -> IO ()
ircViewScrollToBottom a = do
textViewEnd (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewScrollVerticalPage :: Bool -> IrcView -> IO ()
ircViewScrollVerticalPage isDown a = do
let sw = ircViewScrolledWindow a
tv = ircViewView a
pageInc <- (<=<) adjustmentGetPageIncrement scrolledWindowGetVAdjustment sw
textViewScrollVertical tv sw (if isDown then pageInc else ( pageInc))
ircViewApplySelectionMark a
ircViewScrollVerticalStep :: Bool -> IrcView -> IO ()
ircViewScrollVerticalStep isDown a = do
let sw = ircViewScrolledWindow a
tv = ircViewView a
ti <- textViewGetTextIter tv
(_, lineHeight) <- textViewGetLineYrange tv ti
let stepInc = i2d lineHeight
textViewScrollVertical tv sw (if isDown then stepInc else ( stepInc))
ircViewApplySelectionMark a
ircViewSendMorse :: IrcView -> IO ()
ircViewSendMorse view@(IrcView {ircViewBuffer = buffer
,ircViewView = vView}) = do
let textBuffer = ircBufferBuffer buffer
promptMark = ircBufferPromptMark buffer
textViewScrollMarkOnscreen vView promptMark
startIter <- textBufferGetIterAtMark textBuffer promptMark
endIter <- textBufferGetEndIter textBuffer
text <- textBufferGetText textBuffer startIter endIter True
ircViewCleanInput view
if isBlankString text
then pageViewUpdateOutputStatus view "Ignored blank ..." Nothing
else ircViewSend view (UTF8.fromString $ encodeMorse text)
ircViewSendMessage :: Bool -> IrcView -> IO ()
ircViewSendMessage isTranslate
view@(IrcView {ircViewBuffer = buffer
,ircViewView = vView}) = do
let promptMark = ircBufferPromptMark buffer
textViewScrollMarkOnscreen vView promptMark
text <- ircViewGetInput view
ircViewCleanInput view
if isBlankByteString text
then pageViewUpdateOutputStatus view "Ignored blank ..." Nothing
else
if isTranslate
then
forkGuiIO_ (do
pageViewUpdateOutputStatus view "Translation ..." Nothing
lang <- readTVarIO $ ircBufferTranslateLanguage buffer
translate text Nothing lang)
$ \result ->
case result of
Left _ -> do
pageViewUpdateOutputStatus view "Get translation failed, send original message." Nothing
ircViewSend view text
Right translation -> do
pageViewUpdateOutputStatus view "Translation ... completed." Nothing
ircViewSend view translation
else ircViewSend view text
ircViewSelectAll :: IrcView -> IO ()
ircViewSelectAll = textViewSelectAll . ircViewView
ircViewWrapDeleteAction :: IrcView -> IO Bool -> IO ()
ircViewWrapDeleteAction view action =
unlessM action $
pageViewUpdateOutputStatus view "Can't delete uneditable area." Nothing
ircViewDelLines :: IrcView -> IO ()
ircViewDelLines view =
ircViewWrapDeleteAction view (textViewDelLines (ircViewView view))
ircViewDelete :: IrcView -> IO ()
ircViewDelete view =
textViewDelete (ircViewView view) True True >> return ()
ircViewDeleteForwardChar :: IrcView -> IO ()
ircViewDeleteForwardChar view =
ircViewWrapDeleteAction view (textViewDeleteForwardChar (ircViewView view) True)
ircViewDeleteBackwardChar :: IrcView -> IO ()
ircViewDeleteBackwardChar view =
ircViewWrapDeleteAction view (textViewDeleteBackwardChar (ircViewView view) True)
ircViewDeleteForwardWord :: IrcView -> IO ()
ircViewDeleteForwardWord view =
ircViewWrapDeleteAction view (textViewDeleteForwardWord (ircViewView view) True)
ircViewDeleteBackwardWord :: IrcView -> IO ()
ircViewDeleteBackwardWord view =
ircViewWrapDeleteAction view (textViewDeleteBackwardWord (ircViewView view) True)
ircViewDeleteToLineEnd :: IrcView -> IO ()
ircViewDeleteToLineEnd view =
ircViewWrapDeleteAction view (textViewDeleteToLineEnd (ircViewView view) True)
ircViewDeleteToLineStart :: IrcView -> IO ()
ircViewDeleteToLineStart view =
ircViewWrapDeleteAction view (textViewDeleteToLineStart (ircViewView view) True)
ircViewCut :: IrcView -> IO Bool
ircViewCut view = do
textViewCut $ ircViewView view
return True
ircViewCopy :: IrcView -> IO Bool
ircViewCopy view = do
textViewCopy $ ircViewView view
return True
ircViewPaste :: IrcView -> IO Bool
ircViewPaste view = do
textViewPaste $ ircViewView view
return True
ircViewForwardLine :: IrcView -> IO ()
ircViewForwardLine a = do
textViewForwardLine (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewBackwardLine :: IrcView -> IO ()
ircViewBackwardLine a = do
textViewBackwardLine (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewForwardChar :: IrcView -> IO ()
ircViewForwardChar a = do
textViewForwardChar (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewBackwardChar :: IrcView -> IO ()
ircViewBackwardChar a = do
textViewBackwardChar (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewForwardWord :: IrcView -> IO ()
ircViewForwardWord a = do
textViewForwardWord (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewBackwardWord :: IrcView -> IO ()
ircViewBackwardWord a = do
textViewBackwardWord (ircViewView a) (ircViewScrolledWindow a)
ircViewApplySelectionMark a
ircViewSmartHome :: IrcView -> IO ()
ircViewSmartHome a = do
textViewSmartHome $ ircViewView a
ircViewApplySelectionMark a
ircViewSmartEnd :: IrcView -> IO ()
ircViewSmartEnd a = do
textViewSmartEnd $ ircViewView a
ircViewApplySelectionMark a
ircViewToggleSelectionMark :: IrcView -> IO ()
ircViewToggleSelectionMark = textViewToggleSelectionMark . ircViewView
ircViewExchangeSelectionMark :: IrcView -> IO ()
ircViewExchangeSelectionMark = textViewExchangeSelectionMark . ircViewView
ircViewApplySelectionMark :: IrcView -> IO ()
ircViewApplySelectionMark = textViewApplySelectionMark . ircViewView
ircViewNewline :: IrcView -> IO ()
ircViewNewline = textViewNewLine . ircViewView
ircViewGetTextBuffer :: IrcView -> IO TextBuffer
ircViewGetTextBuffer = textViewGetBuffer . ircViewView
ircViewGetSourceBuffer :: IrcView -> IO SourceBuffer
ircViewGetSourceBuffer sb =
castToSourceBuffer <$> ircViewGetTextBuffer sb
ircViewMoveToPrompt :: IrcView -> IO ()
ircViewMoveToPrompt IrcView {ircViewBuffer = buffer
,ircViewView = view} =
textViewPlaceCursorWithMark view (ircBufferPromptMark buffer)
ircViewCleanInput :: IrcView -> IO ()
ircViewCleanInput IrcView {ircViewBuffer = buffer} = do
let textBuffer = ircBufferBuffer buffer
promptMark = ircBufferPromptMark buffer
promptIter <- textBufferGetIterAtMark textBuffer promptMark
endIter <- textBufferGetEndIter textBuffer
textBufferDelete textBuffer promptIter endIter
ircViewGetInput :: IrcView -> IO ByteString
ircViewGetInput IrcView {ircViewBuffer = buffer} = do
let textBuffer = ircBufferBuffer buffer
promptMark = ircBufferPromptMark buffer
promptIter <- textBufferGetIterAtMark textBuffer promptMark
endIter <- textBufferGetEndIter textBuffer
textBufferGetByteString textBuffer promptIter endIter True
ircViewSend :: IrcView -> ByteString -> IO ()
ircViewSend view@(IrcView {ircViewBuffer = buffer})
message = do
nick <- readTVarIO $ ircBufferNick buffer
ircBufferReceivePrivate buffer (B.pack nick) message
let msg = showCommand $ PrivMsgCmd (S.singleton (B.pack $ ircBufferChannel buffer)) message
mkIrcDaemonSignal (pageViewClient view) SendMessage (SendMessageArgs (ircBufferServer buffer) msg)
ircViewOpenUrl :: IrcView -> IO ()
ircViewOpenUrl view@(IrcView {ircViewBuffer = buffer}) =
textBufferGetTagText (ircBufferBuffer buffer) (ircBufferUrlColorTag buffer)
>?>= \ url ->
mkDaemonSignal (pageViewClient view) NewTab (NewTabArgs "PageBrowser" url)
ircViewTranslateMessage :: IrcView -> IO ()
ircViewTranslateMessage view@(IrcView {ircViewBuffer =
IrcBuffer {ircBufferBuffer = buffer
,ircBufferMessageTag = messageTag
,ircBufferTranslateLanguage = language}}) = do
iter <- textBufferGetCurrentLineEndIter_ buffer
textIterBackwardChar iter
textBufferGetTagByteStringWithIter buffer iter messageTag
>?>= \ text ->
forkGuiIO_ (do
pageViewUpdateOutputStatus view "Fetch translation ..." Nothing
lang <- readTVarIO language
translate text Nothing (if lang == targetLanguage
then sourceLanguage
else targetLanguage))
$ \result ->
case result of
Left _ ->
pageViewUpdateOutputStatus view "Fetch translation ... failed." Nothing
Right translation -> do
pageViewUpdateOutputStatus view "Fetch translation ... completed." Nothing
point <- ircViewGetTooltipPoint view
mkDaemonSignal (pageViewClient view)
ShowTooltip
(ShowTooltipArgs (UTF8.toString translation)
(Just point) 10000
Nothing (Just (Color 0 65535 0))
True Nothing)
ircViewTranslateMorse :: IrcView -> IO ()
ircViewTranslateMorse view@(IrcView {ircViewBuffer =
IrcBuffer {ircBufferBuffer = buffer
,ircBufferMessageTag = messageTag}}) = do
iter <- textBufferGetCurrentLineEndIter_ buffer
textIterBackwardChar iter
textBufferGetTagTextWithIter buffer iter messageTag
>?>= \ text -> do
point <- ircViewGetTooltipPoint view
mkDaemonSignal (pageViewClient view)
ShowTooltip
(ShowTooltipArgs (decodeMorse text)
(Just point) 10000
Nothing (Just (Color 65535 65535 0))
True Nothing)
ircViewReadMessage :: IrcView -> IO ()
ircViewReadMessage view@(IrcView {ircViewBuffer =
IrcBuffer {ircBufferBuffer = buffer
,ircBufferMessageTag = messageTag}}) = do
iter <- textBufferGetCurrentLineEndIter_ buffer
textIterBackwardChar iter
textBufferGetTagTextWithIter buffer iter messageTag
>?>= \ text -> ircViewReadText view text
ircViewReadText :: IrcView -> String -> IO ()
ircViewReadText view text =
execute "festival" ("echo " ++ show text ++ " | %s --tts") True
>?>= \ failedReason ->
pageViewUpdateOutputStatus view failedReason Nothing
ircViewGetTooltipPoint :: IrcView -> IO Point
ircViewGetTooltipPoint IrcView {ircViewView = textView} = do
textIter <- textViewGetTextIter textView
(Rectangle x y width height) <- textViewGetIterLocation textView textIter
(wx, wy) <- textViewBufferToWindowCoords textView TextWindowWidget (x, y)
return (wx + width, wy + height)
ircViewKeymap :: Map Text (IrcView -> IO ())
ircViewKeymap =
M.fromList [("Return", ircViewSendMessage False)
,("M-m", ircViewSendMessage False)
,("C-m", ircViewSendMessage True)
,("C-n", ircViewSwitchTranslateLanguage)
,("C-N", ircViewSendMorse)
,("M-M", ircViewMoveToPrompt)
,("M-N", ircViewCleanInput)
,("M-a", ircViewSelectAll)
,("M-d", ircViewDelLines)
,("M-D", ircViewDelete)
,("M-,", ircViewDeleteBackwardChar)
,("M-.", ircViewDeleteForwardChar)
,("M-<", ircViewDeleteBackwardWord)
,("M->", ircViewDeleteForwardWord)
,("M-C-,", ircViewDeleteToLineStart)
,("M-C-.", ircViewDeleteToLineEnd)
,("M-j", ircViewForwardLine)
,("M-k", ircViewBackwardLine)
,("M-l", ircViewForwardChar)
,("M-h", ircViewBackwardChar)
,("Down", ircViewForwardLine)
,("Up", ircViewBackwardLine)
,("Right", ircViewForwardChar)
,("Left", ircViewBackwardChar)
,("S-Return", ircViewNewline)
,("M-L", ircViewForwardWord)
,("M-H", ircViewBackwardWord)
,("M-P-h", ircViewSmartHome)
,("M-P-l", ircViewSmartEnd)
,("C-c", ircViewToggleSelectionMark)
,("C-C", ircViewExchangeSelectionMark)
,("C-o", ircViewOpenUrl)
,("C-j", ircViewTranslateMessage)
,("C-J", ircViewTranslateMorse)
,("C-k", ircViewReadMessage)
]