GUI.hs

module NClient.GUI (gui) where

import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Chan (readChan, writeChan)
import Control.Monad (forever, forM_, void)
import Data.IORef (newIORef, atomicModifyIORef)
import Graphics.Vty
import Graphics.Vty.Widgets.All

import NClient.Connect
import NClient.Message.Format
import qualified NClient.Message.History as H
import qualified NClient.Message.Split as S

gui :: (Input, Output) -> IO ()
gui (i,o) = do
  history <- newIORef $ H.empty 10
  messages <- newList (getNormalAttr defaultContext)
  newMessage <- editWidget
  box <- vBox messages newMessage
  ui <- centered box
  fg <- newFocusGroup
  void $ addToFocusGroup fg newMessage
  c <- newCollection
  void $ addToCollection c ui fg
  -- Send message to server
  newMessage `onActivate` \this ->
    getEditText this >>= toC2S >>= writeChan o
  --
  -- Add send message to history
  newMessage `onActivate` \this ->
    getEditText this >>= \t -> atomicModifyIORef history (\h -> let a = H.prepend t h in (a, H.line a)) >>= setEditText this
  --
  -- Catch history movements
  newMessage `onKeyPressed` \this k m ->
    case (k,m) of
      (KUp, []) -> do
        t <- getEditText this
        t' <- atomicModifyIORef history $
          \h -> let h' = H.next t h in (h', H.line h')
        setEditText this t'
        return True
      (KDown, []) -> do
        t' <- atomicModifyIORef history $
          \h -> let h' = H.previous h in (h', H.line h')
        setEditText this t'
        return True
      _ -> return False
  --
  -- Read server messages when they come
  void . forkIO . forever $ readChan i >>= \m -> do
    let addMessage f xs ys = textWidget f xs >>= addToList ys xs >> scrollDown ys
    schedule $
      do a:as <- S.words (fromS2C m) . region_width <$> getCurrentSize messages
         addMessage (formatter Tail m) a messages
         forM_ as $ \g -> addMessage (formatter Full m) g messages
    threadDelay 10000
  --
  runUi c defaultContext