{-# 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)