matsuri-0.0.4: Main.hs

{-# LANGUAGE RecordWildCards #-}

-- | Main.hs
-- Main program module.

import Buffers
import Config
import Cmd
import Help
import Jabber
import UI
import Utils

import Network
import Network.XMPP.MUC
import Control.Concurrent
import Control.Concurrent.MVar
import qualified Data.Map as M
import Graphics.Vty
import Graphics.Vty.Widgets.All
import qualified Widgets.ListBox as L
import qualified Widgets.EditBox as E


-- | Read configs and start main loop.
main = withSocketsDo $ do
    -- read config
    (config, buffers) <- readConfig ".matsurirc"
    vty <- mkVty
    mev <- newEmptyMVar
    -- main loop
    forkIO $ loopGetEvent mev vty
    DisplayRegion w h <- display_bounds $ terminal vty
    let ui = resizeUI (fromIntegral w) (fromIntegral h) $ defaultUI buffers
    rerender mev vty ui config buffers
    -- disconnect all accounts
    mapM_ disconnect $ [acc | BufAccount acc <- (M.elems buffers)]
    -- shutdown && exiting
    shutdown vty
  where
    loopGetEvent mev vty = do
        event <- next_event vty
        putMVar mev (VtyEvent event)
        loopGetEvent mev vty


-- | Get event and process it.
mainLoop mev vty st@(UIState {..}) config buffers = do
    event <- takeMVar mev
    case event of
      InsBuffer k buffer -> insElem' k buffer
      ---
      NewMsg k msg -> case getBuf k buffers of
        BufChat chat ->
            let contents = msg:(chatContents chat)
            in insElem' k $ BufChat chat{chatContents=contents}
        BufRoom room ->
            let contents = msg:(roomContents room)
            in insElem' k $ BufRoom room{roomContents=contents}
        _ -> skip
      ---
      NewStatus k status' -> case getBuf k buffers of
        BufChat chat -> insElem' k $ BufChat chat{status=status'}
        _ -> skip
      ---
      NewRoomMsg k ev -> case getBuf k buffers of
        BufRoom room -> insElem' k (updRoom ev room)
        _ -> skip
      ---
      RoomPresence k presence -> case getBuf k buffers of
        BufRoom room -> do
            (cnt, occs) <- updateRoomOccupants presence
                                               (roomOccupants room)
                                               (roomNick room)
            let buf = BufRoom room{ roomContents=cnt++(roomContents room)
                                  , roomOccupants=occs }
            insElem' k buf
        _ -> skip
      ---
      RoomList k list -> case getBuf k buffers of
        BufRoom room -> do
            w <- getW'
            info <- withTime " == " (showRoomList list w)
            let cnts = (InfoMsg info):(roomContents room)
            insElem' k $ BufRoom room{roomContents=cnts}
        _ -> skip
      ---
      VtyEvent event' -> case event' of
        -- roster
        EvKey (KASCII 'p') [MCtrl] -> rerender' $ st { roster = L.moveUp roster }
        EvKey (KASCII 'n') [MCtrl] -> rerender' $ st { roster = L.moveDn roster }
        EvKey KEnter [] | E.contents edit == "" ->
          case getBuf cur buffers of
            BufAccount acc ->
                let buf = BufAccount acc{accCollapsed = not $ accCollapsed acc}
                in insElem' cur buf
            BufGroup grp ->
                let buf = BufGroup grp{grpCollapsed = not $ grpCollapsed grp}
                in insElem' cur buf
            _ -> skip
        -- show/hide
        EvKey (KASCII 'v') [MCtrl] ->
          let isShow = getCF "show_roster" config
              isShow' = if null isShow then "1"
                                       else ""
              config' = setCF "show_roster" isShow' config
          in rerender mev vty st config' buffers

        -- editbox
        EvKey (KASCII  c ) []      -> rerender' $ st { edit = E.insert c edit }
        EvKey (KASCII 'a') [MCtrl] -> rerender' $ st { edit = E.moveToHome edit }
        EvKey (KASCII 'f') [MCtrl] -> rerender' $ st { edit = E.moveRight edit }
        EvKey (KASCII 'b') [MCtrl] -> rerender' $ st { edit = E.moveLeft edit }
        EvKey (KASCII 'f') [MMeta] -> rerender' $ st { edit = E.moveWordRight edit }
        EvKey (KASCII 'b') [MMeta] -> rerender' $ st { edit = E.moveWordLeft edit }
        EvKey (KASCII 'e') [MCtrl] -> rerender' $ st { edit = E.moveToEnd edit }
        EvKey KBS          []      -> rerender' $ st { edit = E.backSpace edit }
        EvKey KDel         []      -> rerender' $ st { edit = E.delete edit }
        -- parse command || send message
        EvKey KEnter [] -> case E.contents edit of
          content | words content == ["/quit"] -> return ()
          ('/':'/':msg) -> sendMsg ('/':msg)
          ('/':cmd) -> do
              w <- getW'
              buffers' <- doCmd mev config buffers acc cur cmd w
              let st' = st { edit = E.empty edit
                           , roster = mkListBox roster buffers' }
              rerender mev vty st' config buffers'
          msg -> sendMsg msg
        -- other
        EvResize w h               -> rerender' $ resizeUI w h st
        EvKey (KASCII 'q') [MCtrl] -> return ()
        _                          -> skip
  where
    skip = mainLoop mev vty st config buffers
    rerender' st = rerender mev vty st config buffers
    -- send msg to chat
    sendMsg msg = case getBuf cur buffers of
      -- fix copypaste?
      BufChat chat -> do
          buffer <- sendChatMessage acc chat msg
          let buffers' = insElem cur buffer buffers
              st' = st { edit = E.empty edit }
          rerender mev vty st' config buffers'
      BufRoom room -> do
          sendRoomMessage acc room msg
          let st' = st { edit = E.empty edit }
          rerender mev vty st' config buffers
      _ -> skip
    -- insert new element in buffer (or simply replace old element)
    -- and re-create roster tree
    insElem' k buffer =
        let buffers' = insElem k buffer buffers
            st' = st { roster = mkListBox roster buffers' }
        in rerender mev vty st' config buffers'
    -- current account
    acc = case getBuf cur buffers of
        BufAccount acc' -> acc'
        BufGroup grp -> getAcc' (grpName grp)
        BufChat chat -> getAcc' (chatName chat)
        BufRoom room -> getAcc' (roomName room)
      where getAcc' name = getAcc (takeWhile (/='|') name) buffers
    -- current buffer
    cur = L.cur roster
    -- get textbox width
    getW' = do
        w <- getW vty
        let roster_width = if null $ getCF "show_roster" config
                           then 0
                           else read $ getCF "roster_width" config
            textbox_width = w - roster_width - 1
        return textbox_width


rerender mev vty st config buffers
  = mkImage vty (mkUI st config buffers) >>=
    update vty . pic_for_image >>
    mainLoop mev vty st config buffers