mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
UI: use GTK Window instead of MessageDialog
This commit is contained in:
sheaf
parent
fc2f25cfa6
commit
e2e4ae6bfe
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue