UI.hs

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

import           Control.Concurrent.STM (atomically)
import           Control.Concurrent.STM.TBQueue (TBQueue, writeTBQueue)
import           Control.Concurrent.STM.TMVar (TMVar, putTMVar)
import           Control.Concurrent.STM.TVar (TVar, writeTVar)
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.UIContext
import           MusicScroll.Pipeline
import           MusicScroll.EventLoop

import           Paths_musicScroll


-- Remember to use Gtk.init Nothing before calling this.
getGtkScene :: IO UIContext
getGtkScene = do
  file    <- getDataFileName "app.glade"
  builder <- Gtk.builderNewFromFile (pack file)
  -- We *know* these ids are defined
  let getWidget wid id0 =
        Gtk.builderGetObject builder id0
          >>= Gtk.castTo wid . fromJust >>= return . fromJust
  UIContext <$> 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"

uiThread :: TMVar UIContext -> TBQueue UICallback
         -> TVar (Maybe TrackSuplement) -> IO ()
uiThread ctxMVar outputTB suplTVar = do
  setCurrentThreadAsGUIThread
  _ <- Gtk.init Nothing
  appCtx@(UIContext {..}) <- getGtkScene
  atomically (putTMVar ctxMVar appCtx)
  Gtk.labelSetText titleLabel "MusicScroll"
  Gtk.widgetShowAll mainWindow
  _ <- Gtk.onButtonClicked suplementAcceptButton $
         do getSuplement appCtx >>= \msupl -> do
              case msupl of
                Just supl -> do
                  let callback = suplementPipeline supl
                  atomically (writeTBQueue outputTB callback)
                _ -> pure ()
              atomically (writeTVar suplTVar msupl)
  _ <- Gtk.afterWidgetFocusOutEvent artistSuplementEntry $
          const (defUpdate appCtx *> pure True)
  _ <- Gtk.afterToggleButtonToggled keepArtistNameCheck $ defUpdate appCtx
  _ <- Gtk.onWidgetDestroy mainWindow Gtk.mainQuit
  Gtk.main
  where
    defUpdate :: UIContext -> IO ()
    defUpdate c = getSuplement c >>= atomically . writeTVar suplTVar

getSuplement :: UIContext -> IO (Maybe TrackSuplement)
getSuplement (UIContext {..}) = trackSuplement <$>
  Gtk.entryGetText titleSuplementEntry
  <*> Gtk.entryGetText artistSuplementEntry
  <*> Gtk.getToggleButtonActive keepArtistNameCheck