UI: use GTK Window instead of MessageDialog

This commit is contained in:
sheaf 2024-09-07 11:28:07 +02:00
parent fc2f25cfa6
commit e2e4ae6bfe

View file

@ -1,5 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.Action where
-- base
@ -9,8 +11,6 @@ import Control.Monad.ST
( RealWorld )
import Data.Foldable
( for_ )
import Data.Int
( Int32 )
import Data.List
( uncons )
import Data.Maybe
@ -231,32 +231,47 @@ instance HandleAction OpenFile where
for_ fileNames $ \ filePath -> do
mbDoc <- loadDocument uniqueSupply filePath
case mbDoc of
Left errMessage -> warningDialog window filePath errMessage
Left errMessage -> openFileWarningDialog window filePath errMessage
Right doc -> do
let newDocHist = newHistory doc
newFileTab uiElts vars (Just newDocHist) tabLoc
updateHistoryState uiElts (Just newDocHist)
Nothing -> return ()
warningDialog
:: ( Show errMess, GTK.IsWindow window )
=> window -> FilePath -> errMess -> IO ()
warningDialog window filePath errMess = do
-- GTK 4 TODO: use Window
dialog <- GTK.new GTK.MessageDialog []
GTK.setMessageDialogText dialog
( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
GTK.setWindowResizable dialog True
GTK.setWindowDecorated dialog False
GTK.windowSetTransientFor dialog ( Just window )
GTK.windowSetModal dialog True
widgetAddClasses dialog [ "metabrush", "bg", "plain", "text", "dialog" ]
closeButton <- GTK.dialogAddButton dialog "OK" 1
openFileWarningDialog
:: GTK.IsWindow window
=> window -> FilePath -> String -> IO ()
openFileWarningDialog window filePath errMess = do
dialogWindow <- GTK.windowNew
GTK.setWindowDecorated dialogWindow False
GTK.windowSetTransientFor dialogWindow (Just window)
contentBox <- GTK.boxNew GTK.OrientationVertical 30
GTK.widgetSetMarginStart contentBox 20
GTK.widgetSetMarginEnd contentBox 20
GTK.widgetSetMarginTop contentBox 20
GTK.widgetSetMarginBottom contentBox 20
label <- GTK.labelNew $ Just $ "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack errMess
GTK.boxAppend contentBox label
closeButton <- GTK.buttonNew
GTK.buttonSetLabel closeButton "OK"
GTK.boxAppend contentBox closeButton
GTK.windowSetChild dialogWindow (Just contentBox)
widgetAddClasses dialogWindow ["metabrush", "bg", "plain", "text", "dialog"]
widgetAddClass closeButton "dialogButton"
widgetShow dialog
void $ GTK.afterDialogResponse dialog \ _ -> do
GTK.windowDestroy dialog
void $ GTK.onButtonClicked closeButton $ do
GTK.windowDestroy dialogWindow
GTK.widgetSetVisible dialogWindow True
-- TODO: make the dialog draggable.
-- See https://discourse.gnome.org/t/enabling-window-dragging-on-specific-elements-in-gtk-4/5731/4
-----------------
-- Open folder --
@ -286,7 +301,7 @@ instance HandleAction OpenFolder where
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
mbDoc <- loadDocument uniqueSupply ( folderPath </> filePath )
case mbDoc of
Left errMessage -> warningDialog window filePath errMessage
Left errMessage -> openFileWarningDialog window filePath errMessage
Right doc -> do
let
newDocHist :: DocumentHistory
@ -414,11 +429,6 @@ data Close
{ docToClose :: !Unique }
deriving stock Show
pattern JustClose, SaveAndClose, CancelClose :: Int32
pattern JustClose = 1
pattern SaveAndClose = 2
pattern CancelClose = 3
instance HandleAction Close where
handleAction
uiElts@( UIElements {..} )
@ -436,28 +446,49 @@ instance HandleAction Close where
Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
| unsavedChanges documentContent
-> do
-- GTK 4 TODO: use Window
dialog <- GTK.new GTK.MessageDialog []
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
GTK.setWindowResizable dialog False
GTK.setWindowDecorated dialog False
GTK.windowSetTransientFor dialog ( Just window )
GTK.windowSetModal dialog True
widgetAddClasses dialog [ "metabrush", "bg", "plain", "text", "dialog" ]
closeButton <- GTK.dialogAddButton dialog "Close" JustClose
saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
GTK.dialogSetDefaultResponse dialog JustClose
for_ [ closeButton, saveButton, cancelButton ]
( `widgetAddClass` "dialogButton" )
widgetShow dialog
void $ GTK.onDialogResponse dialog \ choice -> do
case choice of
JustClose -> closeDocument isActiveDoc documentUnique
SaveAndClose -> save uiElts vars False
_ -> pure ()
GTK.windowDestroy dialog
dialogWindow <- GTK.windowNew
GTK.setWindowDecorated dialogWindow False
GTK.windowSetTransientFor dialogWindow (Just window)
contentBox <- GTK.boxNew GTK.OrientationVertical 30
GTK.widgetSetMarginStart contentBox 20
GTK.widgetSetMarginEnd contentBox 20
GTK.widgetSetMarginTop contentBox 20
GTK.widgetSetMarginBottom contentBox 20
GTK.windowSetChild dialogWindow (Just contentBox)
label <- GTK.labelNew $ Just $ "\n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?"
GTK.boxAppend contentBox label
buttonBox <- GTK.boxNew GTK.OrientationHorizontal 0
GTK.boxAppend contentBox buttonBox
closeButton <- GTK.buttonNew
GTK.buttonSetLabel closeButton "Close"
GTK.boxAppend buttonBox closeButton
saveCloseButton <- GTK.buttonNew
GTK.buttonSetLabel saveCloseButton "Save and close"
GTK.boxAppend buttonBox saveCloseButton
cancelButton <- GTK.buttonNew
GTK.buttonSetLabel cancelButton "Cancel"
GTK.boxAppend buttonBox cancelButton
widgetAddClasses dialogWindow ["metabrush", "bg", "plain", "text", "dialog"]
for_ [closeButton, saveCloseButton, cancelButton] \ button ->
widgetAddClass button "dialogButton"
void $ GTK.onButtonClicked closeButton $ do
closeDocument isActiveDoc documentUnique
GTK.windowDestroy dialogWindow
void $ GTK.onButtonClicked saveCloseButton $ do
save uiElts vars False
GTK.windowDestroy dialogWindow
void $ GTK.onButtonClicked cancelButton $ do
GTK.windowDestroy dialogWindow
GTK.widgetSetVisible dialogWindow True
| otherwise
-> closeDocument isActiveDoc documentUnique