GTk Haskell App

sampleChunk_of_App.hs

goApp :: App n -> IO n
goApp init = evalStateT (runApp init) initAppState


scheduleGTKStuff :: IO () -> IO ()
scheduleGTKStuff action = do
  void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do
    action
    return False


uiGo :: IO ()
uiGo = do
  guiChannel <- atomically $ newTChan
  renderChannel <- atomically $ newTChan
  mainRenderer <- initializeMainWindow (guiChannel)
  race_ Gtk.main (race_
                   (renderLoop  mainRenderer (renderChannel))
                   (goApp $ dispatchLoop (guiChannel,renderChannel) ) )

renderLoop ::(GUIState -> IO ()) -> (TChan GUIState) -> IO ()
renderLoop mf recv = 
  forever $ do
     (atomically . readTChan $ recv) >>= (\n -> scheduleGTKStuff $ (mf n) )


dispatchLoop :: (TChan AppSignal, TChan GUIState) -> App ()
dispatchLoop (recv,snd) = do
    event <- liftIO $ atomically . readTChan $ recv
    case event of
         MainQuit -> return ()
         SignalEmpty -> do
            (gets _renderState) >>= (liftIO . atomically . writeTChan snd)
            dispatchLoop (recv,snd)
         EditorBuffer cntxt txt -> do
            modify (replaceEdText cntxt txt)
            {- Etc .. Everything here works basically the same way, updates the
               state, does some IO side effects, and then pushes the updated state to the TChan
                -}


initializeMainWindow :: (TChan AppSignal) -> IO (GUIState -> IO ())
initializeMainWindow bucket = do
  Gtk.init Nothing
  

  win <-  new Gtk.Window [  #title         := "Message Parser"
                                  , #resizable     := False
                                  , #defaultWidth  := 800
                                  , #defaultHeight := 725  ]

  aGrid <-  new Gtk.Grid []
  
  (messageNav,messageNavRender')  <- createmessageNavigator bucket
  (qedWin, qedWinRender') <- quEdWindow bucket
  (filWin, fiWinRender') <- fiEdWindow bucket
  (xfWin, xfWinRender') <- xfEdWindow bucket
  (sideMenu, sideMenuRender' )  <- createSideMenu win qedWin filWin xfWin bucket
  (progressRender) <- inProgressPane win

  let sideMenuRender = sideMenuRender' . _viewVecStatus . _viewerState
      qedWinRender    = qedWinRender' . _edState
      fiWinRender    = fiWinRender' . _edState
      xfWinRender    = xfWinRender' . _edState 
      messageNavRender = messageNavRender' . _viewerState

  Gtk.gridAttach aGrid messageNav 0 0 4 4
  Gtk.gridAttach aGrid sideMenu 4 0 1 4
  #add win aGrid

  on qedWin  #deleteEvent  (return . #hideOnDelete $ qedWin)
  on filWin #deleteEvent  (return . #hideOnDelete $ filWin)
  on xfWin #deleteEvent  (return . #hideOnDelete $ xfWin)
  on win #destroy (mainWindowDismiss bucket) --invokes Gtk.mainQuit via TChan signal handler
  


  #showAll win
  
  return (sequence_ . (<*>) [progressRender,sideMenuRender,qedWinRender,fiWinRender,xfWinRender,messageNavRender] . pure)


  {- and lots of other widgets. 
     Basically every collection of widgets
     returns an update handler to update it based on the part
     of the state object that it cares about. They are all pretty similar in basic structure.
     To write back to the dispatch loop, functions such as the below are registered to the
     Gtk event handlers 
      -}

processEdBuff :: (TChan AppSignal) -> EditorContext -> Gtk.TextBuffer ->  IO ()
processEdBuff snd cntxt buff = do
  (s,e) <- Gtk.textBufferGetBounds buff
  txt <- Gtk.textBufferGetText buff s e False
  atomically $ writeTChan snd (EditorBuffer cntxt txt)


mainWindowDismiss :: (TChan AppSignal) -> IO ()
mainWindowDismiss snd = do
  atomically $ writeTChan snd MainQuit
  Gtk.mainQuit