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