matsuri-0.0.1: Main.hs

{-# LANGUAGE RecordWildCards #-}

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

import Buffers
import Config
import Help
import Jabber
import UI

import Network
import Control.Concurrent
import Control.Concurrent.MVar
import qualified Data.Map as M
import Graphics.Vty
import Graphics.Vty.Widgets.All
import qualified Widgets.Tree as T
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
    rerender mev vty (defaultUI buffers) 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 -> do
            let contents = msg:(chatContents chat)
            insElem' k $ BufChat chat{chatContents=contents}
          _ -> skip
      ---
      NewStatus k status' ->
        case getBuf k buffers of
          BufChat chat -> insElem' k $ BufChat chat{status=status'}
          _ -> skip
      ---
      VtyEvent event' -> case event' of
        -- tree
        EvKey (KASCII 'p') [MCtrl] -> rerender' $ st { roster = T.moveUp roster }
        EvKey (KASCII 'n') [MCtrl] -> rerender' $ st { roster = T.moveDn roster }
        EvKey KEnter [] | E.contents edit == "" ->
          case getAccount cur buffers of
            Just acc ->
                let buf = BufAccount acc{accCollapsed = not $ accCollapsed acc}
                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

        -- edit box
        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 '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
          "/q" -> return ()
          ('/':cmd) -> do
              buffers' <- parseCmd cmd
              let st' = st { edit = E.empty
                           , roster = mkTree roster buffers'
                           }
              rerender mev vty st' config buffers'
          msg -> case getBuf cur buffers of
              BufChat chat -> do
                buffer <- sendChatMessage chat (E.contents edit)
                let buffers' = insElem cur buffer buffers
                    st' = st { edit = E.empty }
                rerender mev vty st' config buffers'
              _ -> skip

        -- other
        EvResize w h               -> rerender' st
        EvKey (KASCII 'q') [MCtrl] -> return ()
        _                          -> skip
  where
    skip = mainLoop mev vty st config buffers
    rerender' st = rerender mev vty st config buffers
    -- 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 = mkTree roster buffers' }
        in rerender mev vty st' config buffers'
    -- connect
    parseCmd "c" = case getAccount cur buffers of
        Just acc -> do
          buffer <- connect mev config acc
          return $ insElem (accName acc) buffer buffers
        _ -> ins2help (InfoMsg "can't connect: not an account")
    -- disconnect
    parseCmd "d" = case getAccount cur buffers of
        Just acc -> do
          buffer <- disconnect acc
          let buffers' = insElem cur buffer buffers
              buffers'' = killBuffers (accName acc++"|") buffers'
          return buffers''
        _ -> ins2help (InfoMsg "can't disconnect: not an account")
      where cur = T.cur roster
    -- help
    parseCmd "help" = ins2help (InfoMsg help_all)
    parseCmd unknown_cmd = ins2help (InfoMsg $ "unknown `"++unknown_cmd++
                                               "' command, try `/help'")
    ---
    cur = T.cur roster
    ins2help cnt = return $ case getBuf "help" buffers of
        BufHelp cnts -> insElem "help" (BufHelp $ cnt:cnts) buffers
        _ -> buffers


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