YataWindow.hs

module YataWindow ( YataWindow
                  , new, showAll
                  , onMessagePost
                  , displayTweets
                  )
where

import Control.Applicative
import Text.Printf (printf)

import Graphics.UI.Gtk hiding (disconnect)
import Graphics.UI.Gtk.Gdk.Events
import Graphics.UI.Gtk.Glade (xmlNew, xmlGetWidget)

import Web.Twitter.Types

maxUpdateChars = 140

data YataWindow
  = YataWindow { mainWindow :: Window
               , messageTextView :: TextView
               , streamTextView :: TextView
               , statusbar :: Statusbar
               }

data YataMenu
  = YataMenu { quitMenuItem :: MenuItem
             }

new :: IO YataWindow
new = do
  (yw, ym) <- build "yata.glade"

  let YataWindow mainWindow
                 messageTextView
                 streamTextView
                 statusbar = yw

  mainWindow `onDestroy` mainQuit
  messageTextView `onTextViewTextChanged` updateStatus yw
  statusbarUpdateDisplayForMessage statusbar ""
  quitMenuItem ym `onActivateLeaf` mainQuit
  return yw

showAll :: YataWindow -> IO ()
showAll = widgetShowAll . mainWindow

onMessagePost :: YataWindow -> (String -> IO ()) -> IO ()
onMessagePost yw post = do
  let tv = messageTextView yw

  onKeyPress tv $ \e -> do
    if eventKeyName e == "Return"
      then do
        textViewGetText tv >>= post
        textViewSetText tv ""
        return True
      else return False

  return ()

onTextViewTextChanged :: TextView -> IO () -> IO ()
onTextViewTextChanged tv io = do
  buffer <- textViewGetBuffer tv
  onBufferChanged buffer io
  return ()

build :: String -> IO (YataWindow, YataMenu)
build gladeFile = do
  Just xml <- xmlNew gladeFile

  yw <-
    YataWindow
      <$> xmlGetWidget xml castToWindow "mainWindow"
      <*> xmlGetWidget xml castToTextView "messageTextView"
      <*> xmlGetWidget xml castToTextView "streamTextView"
      <*> xmlGetWidget xml castToStatusbar "statusbar"

  ym <-
    YataMenu
      <$> xmlGetWidget xml castToMenuItem "quitMenuItem"

  return (yw, ym)

textViewGetText :: TextView -> IO String
textViewGetText tv = do
  buf <- textViewGetBuffer tv
  start <- textBufferGetStartIter buf
  end <- textBufferGetEndIter buf
  textBufferGetText buf start end False

textViewSetText :: TextView -> String -> IO ()
textViewSetText tv text = do
  buf <- textViewGetBuffer tv
  textBufferSetText buf text

updateStatus :: YataWindow -> IO ()
updateStatus yw = do
  let status = statusbar yw
      textView = messageTextView yw
  text <- textViewGetText textView
  statusbarUpdateDisplayForMessage status text

statusbarUpdateDisplayForMessage :: Statusbar -> String -> IO ()
statusbarUpdateDisplayForMessage sb text = do
  let remaining = maxUpdateChars - length text
  statusbarSetText sb . show $ remaining

statusbarSetText :: Statusbar -> String -> IO ()
statusbarSetText sb text = do
  cid <- statusbarGetContextId sb ""
  statusbarPush sb cid text
  return ()

displayTweets :: YataWindow -> [Status] -> IO ()
displayTweets yw ss = do
  let stream = streamTextView yw
      describe s = printf "%s: %s\n" (userScreenName (statusUser s)) (statusText s)
  textViewSetText stream . unlines . map describe $ ss