Gifcurry-3.0.0.1: src/gui/Main.hs
{-
Gifcurry
(C) 2016 David Lettier
lettier.com
-}
{-# LANGUAGE
OverloadedStrings
, NamedFieldPuns
#-}
import GHC.Float
import System.Directory
import System.FilePath
import System.Process
import Text.Printf
import Data.Maybe
import Data.Text
import qualified Data.ByteString.Char8
import Data.List
import Data.IORef
import Data.Word
import Control.Monad
import Control.Concurrent
import Control.Exception
import Data.GI.Base
import qualified GI.GLib
import qualified GI.GObject
import qualified GI.Gdk
import qualified GI.Gtk
import GI.Gst
import Paths_Gifcurry
import qualified Gifcurry
( gif
, GifParams(..)
, defaultGifParams
, gifParamsValid
, getVideoDurationInSeconds
, getOutputFileWithExtension
, getVideoWidthAndHeight
, findOrCreateTemporaryDirectory
)
import qualified GtkMainSyncAsync (gtkMainAsync)
import GuiMisc
import qualified GuiRecords as GR
import qualified GuiPreview
durationTimeWarningLevel :: Float
durationTimeWarningLevel = 10.0
main :: IO ()
main = do
_ <- GI.Gst.init Nothing
_ <- GI.Gtk.init Nothing
builder <- buildBuilder
window <- builderGetObject GI.Gtk.Window builder "gifcurry-window"
startTimeSpinButton <- builderGetObject GI.Gtk.SpinButton builder "start-time-spin-button"
durationTimeSpinButton <- builderGetObject GI.Gtk.SpinButton builder "duration-time-spin-button"
widthSizeSpinButton <- builderGetObject GI.Gtk.SpinButton builder "width-size-spin-button"
qualityPercentSpinButton <- builderGetObject GI.Gtk.SpinButton builder "quality-percent-spin-button"
leftCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "left-crop-spin-button"
rightCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "right-crop-spin-button"
topCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "top-crop-spin-button"
bottomCropSpinButton <- builderGetObject GI.Gtk.SpinButton builder "bottom-crop-spin-button"
inFileChooserButton <- builderGetObject GI.Gtk.FileChooserButton builder "in-file-chooser-button"
outFileChooserButton <- builderGetObject GI.Gtk.FileChooserButton builder "out-file-chooser-button"
fontChooserButton <- builderGetObject GI.Gtk.FontButton builder "font-chooser-button"
saveButton <- builderGetObject GI.Gtk.Button builder "save-button"
openButton <- builderGetObject GI.Gtk.Button builder "open-button"
yesGtkButton <- builderGetObject GI.Gtk.Button builder "yes-button"
noGtkButton <- builderGetObject GI.Gtk.Button builder "no-button"
aboutButton <- builderGetObject GI.Gtk.Button builder "about-button"
giphyUploadButton <- builderGetObject GI.Gtk.Button builder "giphy-upload-button"
imgurUploadButton <- builderGetObject GI.Gtk.Button builder "imgur-upload-button"
saveAsVideoRadioButton <- builderGetObject GI.Gtk.RadioButton builder "save-as-video-radio-button"
widthQualityPercentToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "width-quality-percent-toggle-button"
cropToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "crop-toggle-button"
topBottomTextToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "top-bottom-text-toggle-button"
saveOpenToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "save-open-toggle-button"
uploadToggleButton <- builderGetObject GI.Gtk.ToggleButton builder "upload-toggle-button"
startTimeAdjustment <- builderGetObject GI.Gtk.Adjustment builder "start-time-adjustment"
durationTimeAdjustment <- builderGetObject GI.Gtk.Adjustment builder "duration-time-adjustment"
widthSizeAdjustment <- builderGetObject GI.Gtk.Adjustment builder "width-size-adjustment"
qualityPercentAdjustment <- builderGetObject GI.Gtk.Adjustment builder "quality-percent-adjustment"
outFileNameEntry <- builderGetObject GI.Gtk.Entry builder "out-file-name-entry"
topTextEntry <- builderGetObject GI.Gtk.Entry builder "top-text-entry"
bottomTextEntry <- builderGetObject GI.Gtk.Entry builder "bottom-text-entry"
statusEntry <- builderGetObject GI.Gtk.Entry builder "status-entry"
mainPreviewBox <- builderGetObject GI.Gtk.Box builder "main-preview-box"
imagesPreviewBox <- builderGetObject GI.Gtk.Box builder "images-preview-box"
videoPreviewBox <- builderGetObject GI.Gtk.Box builder "video-preview-box"
videoPreviewOverlayChildBox <- builderGetObject GI.Gtk.Box builder "video-preview-overlay-child-box"
widthQualityPercentBox <- builderGetObject GI.Gtk.Box builder "width-quality-percent-box"
cropSpinButtonsBox <- builderGetObject GI.Gtk.Box builder "crop-spin-buttons-box"
topBottomTextFontChooserBox <- builderGetObject GI.Gtk.Box builder "top-bottom-text-font-chooser-box"
saveOpenBox <- builderGetObject GI.Gtk.Box builder "save-open-box"
uploadBox <- builderGetObject GI.Gtk.Box builder "upload-box"
videoPreviewDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "video-preview-drawing-area"
firstFramePreviewImageDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "first-frame-preview-image-drawing-area"
lastFramePreviewImageDrawingArea <- builderGetObject GI.Gtk.DrawingArea builder "last-frame-preview-image-drawing-area"
firstFrameImage <- builderGetObject GI.Gtk.Image builder "first-frame-image"
lastFrameImage <- builderGetObject GI.Gtk.Image builder "last-frame-image"
longGifGtkMessageDialog <- builderGetObject GI.Gtk.MessageDialog builder "long-gif-message-dialog"
aboutDialog <- builderGetObject GI.Gtk.AboutDialog builder "about-dialog"
startTimeLevelBar <- builderGetObject GI.Gtk.LevelBar builder "start-time-level-bar"
endTimeLevelBar <- builderGetObject GI.Gtk.LevelBar builder "end-time-level-bar"
saveSpinner <- builderGetObject GI.Gtk.Spinner builder "save-spinner"
-- Glade does not allow us to use the response ID nicknames so we setup them up programmatically here.
GI.Gtk.dialogAddActionWidget longGifGtkMessageDialog yesGtkButton (enumToInt32 GI.Gtk.ResponseTypeYes)
GI.Gtk.dialogAddActionWidget longGifGtkMessageDialog noGtkButton (enumToInt32 GI.Gtk.ResponseTypeNo)
(maybeVideoPreviewWidget, maybePlaybinElement) <-
GuiPreview.buildVideoPreviewWidgetAndPlaybinElement
temporaryDirectory <- Gifcurry.findOrCreateTemporaryDirectory
guiPreviewStateRef <- newIORef GR.defaultGuiPreviewState
inVideoPropertiesRef <- newIORef GR.defaultInVideoProperties
let guiComponents =
GR.GuiComponents
{ GR.window = window
, GR.startTimeSpinButton = startTimeSpinButton
, GR.durationTimeSpinButton = durationTimeSpinButton
, GR.widthSizeSpinButton = widthSizeSpinButton
, GR.qualityPercentSpinButton = qualityPercentSpinButton
, GR.leftCropSpinButton = leftCropSpinButton
, GR.rightCropSpinButton = rightCropSpinButton
, GR.topCropSpinButton = topCropSpinButton
, GR.bottomCropSpinButton = bottomCropSpinButton
, GR.inFileChooserButton = inFileChooserButton
, GR.outFileChooserButton = outFileChooserButton
, GR.fontChooserButton = fontChooserButton
, GR.saveButton = saveButton
, GR.openButton = openButton
, GR.yesGtkButton = yesGtkButton
, GR.noGtkButton = noGtkButton
, GR.aboutButton = aboutButton
, GR.giphyUploadButton = giphyUploadButton
, GR.imgurUploadButton = imgurUploadButton
, GR.saveAsVideoRadioButton = saveAsVideoRadioButton
, GR.widthQualityPercentToggleButton = widthQualityPercentToggleButton
, GR.cropToggleButton = cropToggleButton
, GR.topBottomTextToggleButton = topBottomTextToggleButton
, GR.saveOpenToggleButton = saveOpenToggleButton
, GR.uploadToggleButton = uploadToggleButton
, GR.startTimeAdjustment = startTimeAdjustment
, GR.durationTimeAdjustment = durationTimeAdjustment
, GR.widthSizeAdjustment = widthSizeAdjustment
, GR.qualityPercentAdjustment = qualityPercentAdjustment
, GR.outFileNameEntry = outFileNameEntry
, GR.topTextEntry = topTextEntry
, GR.bottomTextEntry = bottomTextEntry
, GR.statusEntry = statusEntry
, GR.mainPreviewBox = mainPreviewBox
, GR.imagesPreviewBox = imagesPreviewBox
, GR.videoPreviewBox = videoPreviewBox
, GR.videoPreviewOverlayChildBox = videoPreviewOverlayChildBox
, GR.widthQualityPercentBox = widthQualityPercentBox
, GR.cropSpinButtonsBox = cropSpinButtonsBox
, GR.topBottomTextFontChooserBox = topBottomTextFontChooserBox
, GR.saveOpenBox = saveOpenBox
, GR.uploadBox = uploadBox
, GR.videoPreviewDrawingArea = videoPreviewDrawingArea
, GR.firstFramePreviewImageDrawingArea = firstFramePreviewImageDrawingArea
, GR.lastFramePreviewImageDrawingArea = lastFramePreviewImageDrawingArea
, GR.firstFrameImage = firstFrameImage
, GR.lastFrameImage = lastFrameImage
, GR.longGifGtkMessageDialog = longGifGtkMessageDialog
, GR.aboutDialog = aboutDialog
, GR.startTimeLevelBar = startTimeLevelBar
, GR.endTimeLevelBar = endTimeLevelBar
, GR.saveSpinner = saveSpinner
, GR.maybeVideoPreviewWidget = maybeVideoPreviewWidget
, GR.maybePlaybinElement = maybePlaybinElement
, GR.temporaryDirectory = temporaryDirectory
, GR.guiPreviewStateRef = guiPreviewStateRef
, GR.inVideoPropertiesRef = inVideoPropertiesRef
}
_ <- hideWidgetsOnRealize guiComponents
_ <- handleInputFileChoice guiComponents
_ <- handleSpinButtons guiComponents
_ <- handleSaveButtonClick guiComponents
_ <- handleOpenButtonClick guiComponents
_ <- handleDialogs guiComponents
_ <- handleSidebarSectionToggleButtons guiComponents
_ <- handleUploadButtons guiComponents
_ <- handleWindow guiComponents
_ <- handleGuiPreview guiComponents
GI.Gtk.main
buildBuilder :: IO GI.Gtk.Builder
buildBuilder = do
gladeFile <- getDataFileName "data/gui.glade"
GI.Gtk.builderNewFromFile (pack gladeFile)
builderGetObject
:: (GI.GObject.GObject b, GI.Gtk.IsBuilder a)
=> (Data.GI.Base.ManagedPtr b -> b)
-> a
-> String
-> IO b
builderGetObject objectTypeClass builder objectId =
fromJust <$> GI.Gtk.builderGetObject builder (pack objectId) >>=
GI.Gtk.unsafeCastTo objectTypeClass
handleInputFileChoice :: GR.GuiComponents -> IO ()
handleInputFileChoice
guiComponents@GR.GuiComponents
{ GR.inFileChooserButton
, GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.leftCropSpinButton
, GR.rightCropSpinButton
, GR.topCropSpinButton
, GR.bottomCropSpinButton
, GR.widthSizeSpinButton
, GR.qualityPercentSpinButton
, GR.topTextEntry
, GR.bottomTextEntry
, GR.outFileNameEntry
, GR.statusEntry
, GR.inVideoPropertiesRef
}
=
void $ GI.Gtk.onFileChooserButtonFileSet inFileChooserButton $ do
inFilePath <- fileChooserButtonGetFilePath inFileChooserButton
maybeVideoDuration <-
Gifcurry.getVideoDurationInSeconds
Gifcurry.defaultGifParams
{ Gifcurry.inputFile = inFilePath }
print maybeVideoDuration
maybeWidthHeight <-
Gifcurry.getVideoWidthAndHeight
Gifcurry.defaultGifParams
{ Gifcurry.inputFile = inFilePath }
case (maybeVideoDuration, maybeWidthHeight) of
(Just videoDuration', Just (width, height)) -> do
atomicWriteIORef inVideoPropertiesRef $
GR.defaultInVideoProperties
{ GR.inVideoDuration = videoDuration'
, GR.inVideoWidth = width
, GR.inVideoHeight = height
}
let videoDuration = float2Double videoDuration'
let startTimeFraction = 0.25
let startTime = videoDuration * startTimeFraction
let endTime = startTime * 3
let durationTime = endTime - startTime
let videoDurationText = Data.Text.pack $ printf "%.3f" videoDuration
_ <- updateStartAndDurationTimeSpinButtonRanges guiComponents
_ <- GI.Gtk.spinButtonSetValue startTimeSpinButton startTime
_ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton durationTime
_ <- updateStatusEntryAsync statusEntry 1 $
Data.Text.concat
[ "That video is about "
, videoDurationText
, " seconds long."
]
return ()
_ -> do
atomicWriteIORef inVideoPropertiesRef GR.defaultInVideoProperties
_ <- updateStartAndDurationTimeSpinButtonRanges guiComponents
_ <- GI.Gtk.spinButtonSetValue startTimeSpinButton 0.0
_ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton 0.0
_ <- updateStatusEntryAsync statusEntry 1 "Is that a video?"
return ()
syncStartAndDurationTimeSpinButtons guiComponents
resetTextEntries
resetWidthAndQualityPercentSpinButtons
resetCropSpinButtons
where
resetTextEntries :: IO ()
resetTextEntries = do
let textEntries =
[ topTextEntry
, bottomTextEntry
, outFileNameEntry
]
mapM_
(flip GI.Gtk.entrySetText "")
textEntries
resetWidthAndQualityPercentSpinButtons :: IO ()
resetWidthAndQualityPercentSpinButtons = do
GI.Gtk.spinButtonSetValue widthSizeSpinButton 500
GI.Gtk.spinButtonSetValue qualityPercentSpinButton 100
resetCropSpinButtons :: IO ()
resetCropSpinButtons = do
let spinButtons =
[ leftCropSpinButton
, rightCropSpinButton
, topCropSpinButton
, bottomCropSpinButton
]
mapM_
(flip GI.Gtk.spinButtonSetValue 0.0)
spinButtons
handleSpinButtons :: GR.GuiComponents -> IO ()
handleSpinButtons
guiComponents@GR.GuiComponents
{ GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.widthSizeSpinButton
, GR.qualityPercentSpinButton
, GR.leftCropSpinButton
, GR.rightCropSpinButton
, GR.topCropSpinButton
, GR.bottomCropSpinButton
, GR.statusEntry
, GR.inVideoPropertiesRef
}
= do
_ <- GI.Gtk.onSpinButtonValueChanged
startTimeSpinButton
handleStartTimeSpinButton
_ <- GI.Gtk.onSpinButtonValueChanged
durationTimeSpinButton
handleDurationTimeSpinButton
_ <- GI.Gtk.onSpinButtonValueChanged
widthSizeSpinButton
handleWidthSizeSpinButton
_ <- GI.Gtk.onSpinButtonValueChanged
qualityPercentSpinButton
handleQualityPercentSpinButton
_ <- GI.Gtk.onSpinButtonValueChanged
leftCropSpinButton
(handleCropSpinButton leftCropSpinButton rightCropSpinButton "left")
_ <- GI.Gtk.onSpinButtonValueChanged
rightCropSpinButton
(handleCropSpinButton rightCropSpinButton leftCropSpinButton "right")
_ <- GI.Gtk.onSpinButtonValueChanged
topCropSpinButton
(handleCropSpinButton topCropSpinButton bottomCropSpinButton "top")
_ <- GI.Gtk.onSpinButtonValueChanged
bottomCropSpinButton
(handleCropSpinButton bottomCropSpinButton topCropSpinButton "bottom")
return ()
where
handleStartTimeSpinButton :: IO ()
handleStartTimeSpinButton = do
startTime <- double2Float <$> GI.Gtk.spinButtonGetValue startTimeSpinButton
_ <- setSpinButtonFraction startTimeSpinButton
if startTime < 0.0
then do
GI.Gtk.entrySetText statusEntry "The start time is wrong."
highlightSpinButton startTimeSpinButton
else do
GI.Gtk.entrySetText statusEntry "Ready."
unhighlightSpinButton startTimeSpinButton
void $ syncStartAndDurationTimeSpinButtons guiComponents
handleDurationTimeSpinButton :: IO ()
handleDurationTimeSpinButton = do
startTime <- double2Float <$> GI.Gtk.spinButtonGetValue startTimeSpinButton
durationTime <- double2Float <$> GI.Gtk.spinButtonGetValue durationTimeSpinButton
videoDuration <- inVideoDuration
_ <- GI.Gtk.setEntryProgressFraction durationTimeSpinButton 0.5
_ <- setSpinButtonFraction durationTimeSpinButton
if
durationTime < 0.0
|| durationTime > (videoDuration - startTime)
|| durationTime > videoDuration
then do
GI.Gtk.entrySetText statusEntry "The duration time is wrong."
highlightSpinButton durationTimeSpinButton
else do
GI.Gtk.entrySetText statusEntry "Ready."
unhighlightSpinButton durationTimeSpinButton
void $ syncStartAndDurationTimeSpinButtons guiComponents
handleWidthSizeSpinButton :: IO ()
handleWidthSizeSpinButton = do
widthSize <- double2Float <$> GI.Gtk.spinButtonGetValue widthSizeSpinButton
_ <- setSpinButtonFraction widthSizeSpinButton
if widthSize <= 0.0
then do
GI.Gtk.entrySetText statusEntry "The width size is wrong."
highlightSpinButton widthSizeSpinButton
else do
GI.Gtk.entrySetText statusEntry "Ready."
unhighlightSpinButton widthSizeSpinButton
handleQualityPercentSpinButton :: IO ()
handleQualityPercentSpinButton = do
qualityPercent <- double2Float <$> GI.Gtk.spinButtonGetValue qualityPercentSpinButton
_ <- setSpinButtonFraction qualityPercentSpinButton
if qualityPercent <= 0.0 || qualityPercent > 100.0
then do
GI.Gtk.entrySetText statusEntry "The quality percent is wrong."
highlightSpinButton qualityPercentSpinButton
else do
GI.Gtk.entrySetText statusEntry "Ready."
unhighlightSpinButton qualityPercentSpinButton
handleCropSpinButton :: GI.Gtk.SpinButton -> GI.Gtk.SpinButton -> Text -> IO ()
handleCropSpinButton a b t = do
cropValue <- double2Float <$> GI.Gtk.spinButtonGetValue a
_ <- setSpinButtonFraction a
if cropValue < 0.0 || cropValue > 100.0
then do
GI.Gtk.entrySetText statusEntry $ Data.Text.concat ["The ", t, " crop is wrong."]
highlightSpinButton a
else do
GI.Gtk.entrySetText statusEntry "Ready."
unhighlightSpinButton a
syncCropSpinButtons a b
syncCropSpinButtons :: GI.Gtk.SpinButton -> GI.Gtk.SpinButton -> IO ()
syncCropSpinButtons a b = do
aValue <- GI.Gtk.spinButtonGetValue a
bValue <- GI.Gtk.spinButtonGetValue b
when (aValue + bValue >= 100) $ do
let newValue = 100.0 - aValue - 1.0
let newValue' = if newValue < 0.0 then 0.0 else newValue
void $ GI.Gtk.spinButtonSetValue b newValue'
return ()
inVideoDuration :: IO Float
inVideoDuration =
GR.inVideoDuration <$> readIORef inVideoPropertiesRef
handleSaveButtonClick :: GR.GuiComponents -> IO ()
handleSaveButtonClick
GR.GuiComponents
{ GR.inFileChooserButton
, GR.outFileChooserButton
, GR.outFileNameEntry
, GR.saveButton
, GR.openButton
, GR.fontChooserButton
, GR.saveAsVideoRadioButton
, GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.widthSizeSpinButton
, GR.qualityPercentSpinButton
, GR.leftCropSpinButton
, GR.rightCropSpinButton
, GR.topCropSpinButton
, GR.bottomCropSpinButton
, GR.topTextEntry
, GR.bottomTextEntry
, GR.statusEntry
, GR.longGifGtkMessageDialog
, GR.saveSpinner
}
=
void $ GI.Gtk.onWidgetButtonReleaseEvent saveButton $ \ _ -> do
inFilePath <- fileChooserButtonGetFilePath inFileChooserButton
startTime <- double2Float <$> GI.Gtk.spinButtonGetValue startTimeSpinButton
durationTime <- double2Float <$> GI.Gtk.spinButtonGetValue durationTimeSpinButton
widthSize <- double2Float <$> GI.Gtk.spinButtonGetValue widthSizeSpinButton
qualityPercent <- double2Float <$> GI.Gtk.spinButtonGetValue qualityPercentSpinButton
leftCrop <- double2Float <$> GI.Gtk.spinButtonGetValue leftCropSpinButton
rightCrop <- double2Float <$> GI.Gtk.spinButtonGetValue rightCropSpinButton
topCrop <- double2Float <$> GI.Gtk.spinButtonGetValue topCropSpinButton
bottomCrop <- double2Float <$> GI.Gtk.spinButtonGetValue bottomCropSpinButton
fontChoice <- GI.Gtk.fontButtonGetFontName fontChooserButton
topText <- GI.Gtk.entryGetText topTextEntry
bottomText <- GI.Gtk.entryGetText bottomTextEntry
saveAsVideo <- GI.Gtk.toggleButtonGetActive saveAsVideoRadioButton
outFilePath <- outFileChooserButtonGetFilePath outFileChooserButton outFileNameEntry
let params =
Gifcurry.defaultGifParams
{ Gifcurry.inputFile = inFilePath
, Gifcurry.outputFile = outFilePath
, Gifcurry.saveAsVideo = saveAsVideo
, Gifcurry.startTime = startTime
, Gifcurry.durationTime = durationTime
, Gifcurry.widthSize = truncate widthSize
, Gifcurry.qualityPercent = qualityPercent
, Gifcurry.fontChoice = unpack fontChoice
, Gifcurry.topText = unpack topText
, Gifcurry.bottomText = unpack bottomText
, Gifcurry.leftCrop = leftCrop
, Gifcurry.rightCrop = rightCrop
, Gifcurry.topCrop = topCrop
, Gifcurry.bottomCrop = bottomCrop
}
paramsValid <- Gifcurry.gifParamsValid params
GI.Gtk.entrySetText statusEntry "Ready."
if paramsValid
then do
longGifGtkMessageDialogResponse <-
if durationTime >= durationTimeWarningLevel
then GI.Gtk.dialogRun longGifGtkMessageDialog
else return (enumToInt32 GI.Gtk.ResponseTypeYes)
when (longGifGtkMessageDialogResponse == enumToInt32 GI.Gtk.ResponseTypeYes) $ do
GI.Gtk.widgetSetSensitive saveButton False
GI.Gtk.widgetSetSensitive openButton False
GI.Gtk.widgetHide saveButton
GI.Gtk.widgetShow saveSpinner
GI.Gtk.setSpinnerActive saveSpinner True
void $ forkOS $ do
GtkMainSyncAsync.gtkMainAsync $
GI.Gtk.entrySetText statusEntry "One GIF coming up!"
result <- Gifcurry.gif params
case result of
Left _ ->
GtkMainSyncAsync.gtkMainAsync $
GI.Gtk.entrySetText statusEntry "Didn't work. Check your settings."
Right filePath -> do
_ <-
forkOS $
GtkMainSyncAsync.gtkMainAsync $
openLocalFileWithDefaultProgram filePath
GtkMainSyncAsync.gtkMainAsync $ GI.Gtk.entrySetText statusEntry "Ready."
GtkMainSyncAsync.gtkMainAsync $ do
GI.Gtk.setSpinnerActive saveSpinner False
GI.Gtk.widgetHide saveSpinner
GI.Gtk.widgetShow saveButton
GI.Gtk.widgetSetSensitive saveButton True
GI.Gtk.widgetSetSensitive openButton True
else GI.Gtk.entrySetText statusEntry "The settings are wrong."
return True
handleOpenButtonClick :: GR.GuiComponents -> IO ()
handleOpenButtonClick
GR.GuiComponents
{ GR.openButton
, GR.saveAsVideoRadioButton
, GR.outFileChooserButton
, GR.outFileNameEntry
, GR.statusEntry
}
=
void $GI.Gtk.onWidgetButtonReleaseEvent openButton $ \ _ -> do
saveAsVideo <- GI.Gtk.toggleButtonGetActive saveAsVideoRadioButton
outFilePath <- outFileChooserButtonGetFilePath outFileChooserButton outFileNameEntry
let outFilePath' =
Gifcurry.getOutputFileWithExtension $
Gifcurry.defaultGifParams
{ Gifcurry.outputFile = outFilePath, Gifcurry.saveAsVideo = saveAsVideo }
fileExists <- doesFileExist outFilePath'
if fileExists
then do
GI.Gtk.entrySetText statusEntry "Ready."
void $
forkIO $
GtkMainSyncAsync.gtkMainAsync $
openLocalFileWithDefaultProgram outFilePath'
else GI.Gtk.entrySetText statusEntry "Couldn't find the file. Check your settings."
return True
handleDialogs :: GR.GuiComponents -> IO ()
handleDialogs
GR.GuiComponents
{ GR.aboutDialog
, GR.longGifGtkMessageDialog
, GR.aboutButton
}
= do
_ <- GI.Gtk.onWidgetButtonReleaseEvent
aboutButton
(\ _ -> GI.Gtk.dialogRun aboutDialog >> return True)
_ <- GI.Gtk.onDialogResponse
longGifGtkMessageDialog
(\ _ -> GI.Gtk.widgetHide longGifGtkMessageDialog)
_ <- GI.Gtk.onDialogResponse
aboutDialog
(\ _ -> GI.Gtk.widgetHide aboutDialog)
return ()
-- GI.Gtk.Expander does not work.
-- While it visually hides its children, they are still present
-- in terms of activation. This prevents the children of
-- other expanded sections from working.
-- This workaround emulates the expander functionality.
handleSidebarSectionToggleButtons :: GR.GuiComponents -> IO ()
handleSidebarSectionToggleButtons
GR.GuiComponents
{ GR.widthQualityPercentToggleButton
, GR.cropToggleButton
, GR.topBottomTextToggleButton
, GR.saveOpenToggleButton
, GR.uploadToggleButton
, GR.widthQualityPercentBox
, GR.cropSpinButtonsBox
, GR.topBottomTextFontChooserBox
, GR.saveOpenBox
, GR.uploadBox
}
= do
let toggleButtons =
[ widthQualityPercentToggleButton
, cropToggleButton
, topBottomTextToggleButton
, saveOpenToggleButton
, uploadToggleButton
]
let boxes =
[ widthQualityPercentBox
, cropSpinButtonsBox
, topBottomTextFontChooserBox
, saveOpenBox
, uploadBox
]
mapM_
(\ (toggleButton, box) ->
void $
GI.Gtk.onToggleButtonToggled toggleButton $
handleOnToggle
toggleButton
box
toggleButtons
) $
Data.List.zip toggleButtons boxes
where
handleOnToggle :: GI.Gtk.ToggleButton -> GI.Gtk.Box -> [GI.Gtk.ToggleButton] -> IO ()
handleOnToggle toggleButton box toggleButtons = do
active <- GI.Gtk.toggleButtonGetActive toggleButton
if active
then do
GI.Gtk.widgetShow box
mapM_
(\ x ->
isNotToggleButton x >>= \ b -> when b $ GI.Gtk.setToggleButtonActive x False
)
toggleButtons
else
GI.Gtk.widgetHide box
where
isNotToggleButton :: GI.Gtk.ToggleButton -> IO Bool
isNotToggleButton x = do
a <- GI.Gtk.widgetGetName toggleButton
b <- GI.Gtk.widgetGetName x
return $ a /= b
handleUploadButtons :: GR.GuiComponents -> IO ()
handleUploadButtons
GR.GuiComponents
{ GR.giphyUploadButton
, GR.imgurUploadButton
}
=
mapM_
(\ (button, link) ->
GI.Gtk.onButtonClicked button $ openUriWithDefaultProgram link
)
[ (giphyUploadButton, "https://giphy.com/upload/")
, (imgurUploadButton, "https://imgur.com/upload")
]
handleGuiPreview :: GR.GuiComponents -> IO ()
handleGuiPreview = GuiPreview.runGuiPreview
handleWindow :: GR.GuiComponents -> IO ()
handleWindow GR.GuiComponents { GR.window } = do
-- Setting the window to resizable false causes the video
-- to load at its natural size.
-- This workaround locks the window size which is required
-- to get accurate crop measurements.
geometry <- GI.Gdk.newZeroGeometry
GI.Gdk.setGeometryMinWidth geometry 1
GI.Gdk.setGeometryMaxWidth geometry 1
GI.Gdk.setGeometryMinHeight geometry 1
GI.Gdk.setGeometryMaxHeight geometry 1
GI.Gtk.windowSetGeometryHints
window
(Just window)
(Just geometry)
[GI.Gdk.WindowHintsMinSize, GI.Gdk.WindowHintsMaxSize]
_ <- GI.Gtk.onWidgetDestroy window GI.Gtk.mainQuit
GI.Gtk.widgetShowAll window
openLocalFileWithDefaultProgram :: String -> IO ()
openLocalFileWithDefaultProgram filePath = do
fileExists <- doesFileExist filePath
when fileExists $ openUriWithDefaultProgram filePath
openUriWithDefaultProgram :: String -> IO ()
openUriWithDefaultProgram uri = do
maybeFileOpenCommand <- determineFileOpenCommand
case maybeFileOpenCommand of
Just fileOpenCommand ->
void $ spawnCommand $ fileOpenCommand ++ " \"" ++ uri ++ "\""
_ -> return ()
where
determineFileOpenCommand :: IO (Maybe String)
determineFileOpenCommand = do
uname <- tryReadProcess "uname" ["-a"]
swVers <- tryReadProcess "sw_vers" []
ver <- tryReadProcess "ver" []
let linuxCommand = "xdg-open"
let macCommand = "open"
let windowsCommand = "explorer"
case (uname, swVers, ver) of
(Right s, _, _) ->
case (containsText "darwin" s, containsText "linux" s) of
(True, _) -> return $ Just macCommand
(_, True) -> return $ Just linuxCommand
_ -> return Nothing
(_, Right s, _) -> returnIf "mac" s macCommand
(_, _, Right s) -> returnIf "windows" s windowsCommand
_ -> return Nothing
where
tryReadProcess :: String -> [String] -> IO (Either IOError String)
tryReadProcess process params = try $ readProcess process params []
returnIf :: Text -> String -> String -> IO (Maybe String)
returnIf needle haystack command =
if containsText needle haystack
then return $ Just command
else return Nothing
containsText :: Text -> String -> Bool
containsText needle haystack =
Data.Text.isInfixOf
needle
(Data.Text.toLower $ Data.Text.pack haystack)
outFileChooserButtonGetFilePath :: GI.Gtk.FileChooserButton -> GI.Gtk.Entry -> IO String
outFileChooserButtonGetFilePath outFileChooserButton outFileNameEntry = do
filePath <- fileChooserButtonGetString outFileChooserButton
fileName <- Data.Text.unpack . Data.Text.strip <$> GI.Gtk.entryGetText outFileNameEntry
if Data.List.null filePath || Data.List.null fileName
then return fileName
else do
isDirectory <- System.Directory.doesDirectoryExist filePath
if isDirectory
then return $ System.FilePath.combine filePath fileName
else return fileName
highlightSpinButton :: GI.Gtk.SpinButton -> IO ()
highlightSpinButton = highlightWidget "spinbutton" " entry "
unhighlightSpinButton :: GI.Gtk.SpinButton -> IO ()
unhighlightSpinButton = unhighlightWidget "spinbutton" " entry "
highlightWidget :: GI.Gtk.IsWidget a => Text -> Text -> a -> IO ()
highlightWidget namePrefix namePostfix =
styleWidget namePrefix namePostfix "{ background-color: #ff4757; color: #f1f2f6; }"
unhighlightWidget :: GI.Gtk.IsWidget a => Text -> Text -> a -> IO ()
unhighlightWidget namePrefix namePostfix =
styleWidget namePrefix namePostfix "{}"
styleWidget :: GI.Gtk.IsWidget a => Text -> Text -> Text -> a -> IO()
styleWidget namePrefix namePostfix style widget = do
name <- GI.Gtk.widgetGetName widget
provider <- GI.Gtk.cssProviderGetDefault
let css =
Data.ByteString.Char8.pack $
Data.Text.unpack $
Data.Text.concat
[ namePrefix
, "#"
, name
, namePostfix
, " "
, style
]
GI.Gtk.cssProviderLoadFromData provider css
styleContext <- GI.Gtk.widgetGetStyleContext widget
void $
GI.Gtk.styleContextAddProvider
styleContext
provider
(fromIntegral GI.Gtk.STYLE_PROVIDER_PRIORITY_USER :: Word32)
updateStatusEntryAsync :: GI.Gtk.Entry -> Word32 -> Text -> IO ()
updateStatusEntryAsync statusEntry seconds message =
void $ GI.GLib.timeoutAdd
GI.GLib.PRIORITY_DEFAULT
seconds $ do
GtkMainSyncAsync.gtkMainAsync $
GI.Gtk.entrySetText statusEntry message
return False
setSpinButtonFraction :: GI.Gtk.SpinButton -> IO ()
setSpinButtonFraction spinButton = do
(_, maxValue) <- GI.Gtk.spinButtonGetRange spinButton
value <- GI.Gtk.spinButtonGetValue spinButton
let fraction = if maxValue <= 0.0 then 0.0 else abs $ value / maxValue
void $ GI.Gtk.setEntryProgressFraction spinButton fraction
updateStartAndDurationTimeSpinButtonRanges :: GR.GuiComponents -> IO ()
updateStartAndDurationTimeSpinButtonRanges
GR.GuiComponents
{ GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.inVideoPropertiesRef
}
= do
videoDuration <- float2Double . GR.inVideoDuration <$> readIORef inVideoPropertiesRef
let buffer = if videoDuration * 0.01 > 0.1 then 0.1 else videoDuration * 0.01
_ <- GI.Gtk.spinButtonSetRange startTimeSpinButton 0.0 (videoDuration - buffer)
_ <- GI.Gtk.spinButtonSetRange durationTimeSpinButton buffer videoDuration
return ()
updateStartAndDurationTimeSpinButtonFractions :: GR.GuiComponents -> IO ()
updateStartAndDurationTimeSpinButtonFractions
GR.GuiComponents
{ GR.startTimeSpinButton
, GR.durationTimeSpinButton
}
= do
_ <- setSpinButtonFraction startTimeSpinButton
_ <- setSpinButtonFraction durationTimeSpinButton
return ()
syncStartAndDurationTimeSpinButtons :: GR.GuiComponents -> IO ()
syncStartAndDurationTimeSpinButtons
guiComponents@GR.GuiComponents
{ GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.inVideoPropertiesRef
}
= do
startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton
durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton
videoDuration <- float2Double . GR.inVideoDuration <$> readIORef inVideoPropertiesRef
let maxDurationTime =
if videoDuration - startTime <= 0.0 then 0.0 else videoDuration - startTime
let durationTime' =
if durationTime > maxDurationTime then maxDurationTime else durationTime
let startTime' = if startTime >= videoDuration then videoDuration else startTime
_ <- updateStartAndDurationTimeSpinButtonRanges guiComponents
_ <- GI.Gtk.spinButtonSetValue startTimeSpinButton startTime'
_ <- GI.Gtk.spinButtonSetValue durationTimeSpinButton durationTime'
updateStartAndDurationTimeSpinButtonFractions guiComponents
updateStartAndEndTimeLevelBars guiComponents
updateStartAndEndTimeLevelBars :: GR.GuiComponents -> IO ()
updateStartAndEndTimeLevelBars
GR.GuiComponents
{ GR.startTimeSpinButton
, GR.durationTimeSpinButton
, GR.startTimeLevelBar
, GR.endTimeLevelBar
, GR.inVideoPropertiesRef
}
= do
startTime <- GI.Gtk.spinButtonGetValue startTimeSpinButton
durationTime <- GI.Gtk.spinButtonGetValue durationTimeSpinButton
videoDuration <- float2Double . GR.inVideoDuration <$> readIORef inVideoPropertiesRef
let endTime = startTime + durationTime
let endTime' = videoDuration - endTime
_ <- GI.Gtk.levelBarSetMinValue startTimeLevelBar 0.0
_ <- GI.Gtk.levelBarSetMinValue endTimeLevelBar 0.0
_ <- GI.Gtk.levelBarSetMaxValue startTimeLevelBar $ checkValue videoDuration
_ <- GI.Gtk.levelBarSetMaxValue endTimeLevelBar $ checkValue videoDuration
_ <- GI.Gtk.levelBarSetValue startTimeLevelBar $ checkValue startTime
_ <- GI.Gtk.levelBarSetValue endTimeLevelBar $ checkValue endTime'
return ()
where
checkValue :: Double -> Double
checkValue v = if v <= levelBarBuffer then levelBarBuffer else v
levelBarBuffer :: Double
levelBarBuffer = 0.03
hideWidgetsOnRealize :: GR.GuiComponents -> IO ()
hideWidgetsOnRealize
GR.GuiComponents
{ GR.saveSpinner
, GR.widthQualityPercentBox
, GR.cropSpinButtonsBox
, GR.topBottomTextFontChooserBox
, GR.saveOpenBox
, GR.uploadBox
}
= do
hideOnRealize saveSpinner
let boxes =
[ widthQualityPercentBox
, cropSpinButtonsBox
, topBottomTextFontChooserBox
, saveOpenBox
, uploadBox
]
mapM_ hideOnRealize boxes
where
hideOnRealize :: GI.Gtk.IsWidget a => a -> IO ()
hideOnRealize w = void $ GI.Gtk.onWidgetRealize w $ GI.Gtk.widgetHide w