UI.hs

{-# language RecordWildCards, OverloadedStrings #-}
module MusicScroll.UI (setupUIThread) where

import           Control.Concurrent.Async
                     (withAsyncBound, waitAnyCancel, withAsync)
import           Control.Concurrent.STM (atomically)
import           Control.Concurrent.STM.TBQueue (TBQueue, readTBQueue, writeTBQueue)
import           Control.Concurrent.STM.TMVar
                     (TMVar, newEmptyTMVar, takeTMVar, putTMVar)
import           Control.Exception (throwIO, AsyncException(UserInterrupt))
import           Control.Monad (forever)
import           Data.Functor (void)
import           Data.GI.Gtk.Threading (setCurrentThreadAsGUIThread)
import           Data.Maybe (fromJust)
import           Data.Text (pack)
import qualified GI.Gtk as Gtk

import           MusicScroll.TrackSuplement
import           MusicScroll.UIEvent

import           Paths_musicScroll


-- Remember to use Gtk.init Nothing before calling this.
getGtkScene :: IO AppContext
getGtkScene = do
  file    <- getDataFileName "app.glade"
  builder <- Gtk.builderNewFromFile (pack file)
  -- We *know* these ids are defined
  let getWidget wid id =
        Gtk.builderGetObject builder id
          >>= Gtk.castTo wid . fromJust >>= return . fromJust
  AppContext <$> getWidget Gtk.Window "mainWindow"
             <*> getWidget Gtk.Label "titleLabel"
             <*> getWidget Gtk.Label "artistLabel"
             <*> getWidget Gtk.TextView "lyricsTextView"
             <*> getWidget Gtk.Label "errorLabel"
             <*> getWidget Gtk.Entry "titleSuplementEntry"
             <*> getWidget Gtk.Entry "artistSuplementEntry"
             <*> getWidget Gtk.Button "suplementAcceptButton"
             <*> getWidget Gtk.CheckButton "keepArtistNameCheck"

setupUIThread :: TBQueue UIEvent -> TBQueue TrackSuplement -> IO ()
setupUIThread events outSupl =
  do appCtxMVar <- atomically newEmptyTMVar
     withAsyncBound (uiThread appCtxMVar outSupl) $ \a1 ->
       withAsync (uiUpdateThread events appCtxMVar) $ \a2 ->
         void (waitAnyCancel [a1, a2]) >> throwIO UserInterrupt

uiThread :: TMVar AppContext -> TBQueue TrackSuplement -> IO ()
uiThread ctxMVar outSupl = do
  setCurrentThreadAsGUIThread
  _ <- Gtk.init Nothing
  appCtx@(AppContext {..}) <- getGtkScene
  atomically (putTMVar ctxMVar appCtx)
  Gtk.labelSetText titleLabel "MusicScroll"
  Gtk.widgetShowAll mainWindow
  _ <- Gtk.onButtonClicked suplementAcceptButton $
         sendSuplementalInfo appCtx outSupl
  _ <- Gtk.onWidgetDestroy mainWindow Gtk.mainQuit
  Gtk.main

---
uiUpdateThread :: TBQueue UIEvent -> TMVar AppContext -> IO a
uiUpdateThread input ctxMVar = do
  appCtx <- atomically (takeTMVar ctxMVar)
  forever $ do
    event <- atomically (readTBQueue input)
    case event of
      GotLyric track lyrics -> updateNewLyrics appCtx (track, lyrics)
      ErrorOn cause -> updateErrorCause appCtx cause

sendSuplementalInfo :: AppContext -> TBQueue TrackSuplement -> IO ()
sendSuplementalInfo (AppContext {..}) suplChan =
  do trackSupl <- TrackSuplement <$> Gtk.entryGetText titleSuplementEntry
                                 <*> Gtk.entryGetText artistSuplementEntry
     atomically (writeTBQueue suplChan trackSupl)