movie-monad-0.0.2.0: src/Window.hs

{-
  Movie Monad
  (C) 2017 David lettier
  lettier.com
-}

{-# LANGUAGE OverloadedStrings #-}

module Window where

import GHC.Word
import Control.Monad
import Data.Int
import Data.IORef
import Data.Time.Clock.POSIX
import GI.GLib
import qualified GI.Gdk
import qualified GI.Gtk
import qualified GI.Gst

import qualified Records as R
import Constants
import Mouse
import PlayPause
import Utils

addWindowHandlers :: R.Application -> [R.Application -> IO ()] -> IO ()
addWindowHandlers
  application@R.Application {
        R.guiObjects = R.GuiObjects {
              R.window = window
            , R.videoWidget = videoWidget
          }
      , R.ioRefs = R.IORefs {
              R.isWindowFullScreenRef = isWindowFullScreenRef
          }
      , R.playbin = playbin
    }
  functionsToRunOnWindowRealized
  =
  void (
      GI.Gtk.onWidgetRealize videoWidget (
          windowRealizedHandler
            application
            functionsToRunOnWindowRealized
        )
    ) >>
  void (
      GI.Gtk.onWidgetWindowStateEvent window (widgetWindowStateEventHandler isWindowFullScreenRef)
    ) >>
  void (
      GI.Gtk.onWidgetDestroy window (windowDestroyHandler playbin)
    ) >>
  void (
      GI.GLib.timeoutAddSeconds GI.GLib.PRIORITY_DEFAULT 1 (hideOnScreenControls application)
    )

windowRealizedHandler ::
  R.Application ->
  [R.Application -> IO ()] ->
  GI.Gtk.WidgetRealizeCallback
windowRealizedHandler
  application@R.Application {
        R.guiObjects = guiObjects@R.GuiObjects {
              R.videoWidget = videoWidget
            , R.seekScale = seekScale
          }
    }
  functionsToRunOnWindowRealized
  = do
  let eventMask = enumToInt32 GI.Gdk.EventMaskAllEventsMask
  GI.Gtk.widgetAddEvents videoWidget eventMask
  GI.Gtk.widgetAddEvents seekScale eventMask
  resetWindow guiObjects
  mapM_ (\ f -> f application) functionsToRunOnWindowRealized

widgetWindowStateEventHandler ::
  IORef Bool ->
  GI.Gdk.EventWindowState ->
  IO Bool
widgetWindowStateEventHandler isWindowFullScreenRef eventWindowState = do
  windowStates <- GI.Gdk.getEventWindowStateNewWindowState eventWindowState
  let isWindowFullScreen = Prelude.foldl (\ acc x ->
          acc || GI.Gdk.WindowStateFullscreen == x
        ) False windowStates
  atomicWriteIORef isWindowFullScreenRef isWindowFullScreen
  return True

windowDestroyHandler ::
  GI.Gst.Element ->
  IO ()
windowDestroyHandler playbin = do
  _ <- GI.Gst.elementSetState playbin GI.Gst.StateNull
  _ <- GI.Gst.objectUnref playbin
  GI.Gtk.mainQuit

hideOnScreenControls ::
  R.Application ->
  IO Bool
hideOnScreenControls
  R.Application {
        R.guiObjects = R.GuiObjects {
              R.window = window
            , R.fileChooserButton = fileChooserButton
            , R.bottomControlsGtkBox = bottomControlsGtkBox
          }
      , R.ioRefs = R.IORefs {
            R.videoInfoRef = videoInfoRef
          , R.mouseMovedLastRef = mouseMovedLastRef
        }
      , R.playbin = playbin
    }
  = do
  isVideo <- R.isVideo <$> readIORef videoInfoRef
  mouseMovedLast <- readIORef mouseMovedLastRef
  timeNow <- fmap round getPOSIXTime
  (_, playBinState, _) <- GI.Gst.elementGetState playbin (fromIntegral GI.Gst.MSECOND :: GHC.Word.Word64)
  let isPlaying = GI.Gst.StatePlaying == playBinState
  let delta = timeNow - mouseMovedLast
  when (isPlaying && isVideo && delta >= hideOnScreenControlsInterval) $ do
    GI.Gtk.widgetHide fileChooserButton
    GI.Gtk.widgetHide bottomControlsGtkBox
    setCursor window (Just "none")
    atomicWriteIORef mouseMovedLastRef timeNow
  return True

calculateWindowSize :: Int -> R.VideoInfo -> IO (Maybe (Int32, Int32))
calculateWindowSize videoWidthSelection retrievedVideoInfo =
  widthHeightToDouble retrievedVideoInfo >>=
  ratio >>=
  windowSize
  where
    widthHeightToDouble :: R.VideoInfo -> IO (Maybe Double, Maybe Double)
    widthHeightToDouble R.VideoInfo { R.isVideo = False } = return (Nothing, Nothing)
    widthHeightToDouble R.VideoInfo { R.videoWidth = w, R.videoHeight = h } =
      return (Just $ fromIntegral w :: Maybe Double, Just $ fromIntegral h :: Maybe Double)
    ratio :: (Maybe Double, Maybe Double) -> IO (Maybe Double)
    ratio (Just width, Just height) =
      if width <= 0.0 then return Nothing else return (Just (height / width))
    ratio _ = return Nothing
    windowSize :: Maybe Double -> IO (Maybe (Int32, Int32))
    windowSize Nothing = return Nothing
    windowSize (Just ratio') =
      return (
          Just (
                fromIntegral videoWidthSelection :: Int32
              , round ((fromIntegral videoWidthSelection :: Double) *  ratio') :: Int32
            )
        )

setWindowSize ::
  Int32 ->
  Int32 ->
  GI.Gtk.Button ->
  GI.Gtk.Widget ->
  GI.Gtk.Window ->
  IO ()
setWindowSize width height fileChooserButton videoWidget window = do
  GI.Gtk.setWidgetWidthRequest fileChooserButton width
  GI.Gtk.setWidgetWidthRequest videoWidget width
  GI.Gtk.setWidgetHeightRequest videoWidget height
  GI.Gtk.setWidgetWidthRequest window width
  GI.Gtk.setWidgetHeightRequest window height
  GI.Gtk.windowResize window width (if height <= 0 then 1 else height)

resetWindow ::
  R.GuiObjects ->
  IO ()
resetWindow
  R.GuiObjects {
        R.window = window
      , R.fileChooserButton = fileChooserButton
      , R.videoWidget = videoWidget
      , R.seekScale = seekScale
      , R.playPauseButton = playPauseButton
      , R.videoWidthSelectionComboBox = videoWidthSelectionComboBox
      , R.fullscreenButton = fullscreenButton
      , R.playImage = playImage
      , R.pauseImage = pauseImage
      , R.bottomControlsGtkBox = bottomControlsGtkBox
    }
  = do
  videoWidthSelection <- getSelectedVideoWidth videoWidthSelectionComboBox
  let width = fromIntegral videoWidthSelection :: Int32
  GI.Gtk.windowUnfullscreen window
  GI.Gtk.widgetHide videoWidget
  GI.Gtk.widgetHide seekScale
  GI.Gtk.widgetHide playPauseButton
  GI.Gtk.widgetHide fullscreenButton
  GI.Gtk.widgetShow fileChooserButton
  GI.Gtk.widgetShow bottomControlsGtkBox
  GI.Gtk.widgetShow videoWidthSelectionComboBox
  setCursor window Nothing
  setPlayPauseButton playPauseButton playImage pauseImage False
  setWindowSize width 0 fileChooserButton videoWidget window