mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
update title and file tab upon change, close
This commit is contained in:
sheaf
parent
341a8ed0ca
commit
86729cb462
|
|
@ -21,6 +21,8 @@ import System.Exit
|
|||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty )
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
|
|
@ -187,6 +189,7 @@ main = do
|
|||
toolTVar <- STM.newTVarIO @Tool Selection
|
||||
modeTVar <- STM.newTVarIO @Mode Path
|
||||
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
|
||||
fileBarTabsTVar <- STM.newTVarIO @( Map Unique GTK.Box ) Map.empty
|
||||
|
||||
-- Put all these stateful variables in a record for conciseness.
|
||||
let
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ import Data.Act
|
|||
|
||||
-- containers
|
||||
import qualified Data.Map as Map
|
||||
( lookup, insert, delete )
|
||||
( lookup, insert )
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
|
|
@ -76,6 +76,7 @@ import MetaBrush.Context
|
|||
, Modifier(..), modifierKey
|
||||
, HoldAction(..), PartialPath(..)
|
||||
, currentDocument, withCurrentDocument, modifyingCurrentDocument
|
||||
, updateTitle
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
|
|
@ -227,7 +228,7 @@ instance HandleAction SaveAs where
|
|||
Just doc -> saveAs uiElts vars True doc
|
||||
|
||||
saveAs :: UIElements -> Variables -> Bool -> Document -> IO ()
|
||||
saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar } ) keepOpen doc = do
|
||||
saveAs ( UIElements { .. } ) vars@( Variables { openDocumentsTVar } ) keepOpen doc = do
|
||||
fileChooser <-
|
||||
GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
|
||||
GTK.FileChooserActionSave
|
||||
|
|
@ -258,7 +259,7 @@ saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar }
|
|||
( Map.insert ( documentUnique doc )
|
||||
( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } )
|
||||
)
|
||||
else removeFileTab fileBar vars ( documentUnique doc )
|
||||
else removeFileTab window title viewportDrawingArea infoBar vars ( documentUnique doc )
|
||||
|
||||
-----------
|
||||
-- Close --
|
||||
|
|
@ -266,14 +267,9 @@ saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar }
|
|||
|
||||
data Close
|
||||
= CloseActive -- ^ Close active document.
|
||||
| CloseThis -- ^ Close a specific tab (action to destroy tab is directly given).
|
||||
{ docToClose :: Unique
|
||||
, destroyTabAction :: IO ()
|
||||
}
|
||||
|
||||
instance Show Close where
|
||||
show CloseActive = "CloseActive"
|
||||
show ( CloseThis docToClose _ ) = "CloseThis " <> show docToClose
|
||||
| CloseThis -- ^ Close a specific tab.
|
||||
{ docToClose :: Unique }
|
||||
deriving stock Show
|
||||
|
||||
pattern JustClose, SaveAndClose, CancelClose :: Int32
|
||||
pattern JustClose = 1
|
||||
|
|
@ -281,38 +277,58 @@ pattern SaveAndClose = 2
|
|||
pattern CancelClose = 3
|
||||
|
||||
instance HandleAction Close where
|
||||
handleAction uiElts@( UIElements { window, fileBar } ) vars@( Variables { .. } ) close = do
|
||||
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do
|
||||
mbDoc <- case close of
|
||||
CloseActive -> STM.atomically $ currentDocument vars
|
||||
CloseThis unique _ -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
||||
CloseActive -> STM.atomically ( currentDocument vars )
|
||||
CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
||||
case mbDoc of
|
||||
Nothing -> pure () -- could show a warning message
|
||||
Just doc@( Document { displayName, documentUnique } ) -> do
|
||||
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.widgetAddEvents dialog
|
||||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
||||
GTK.windowSetTransientFor dialog ( Just window )
|
||||
GTK.windowSetModal dialog True
|
||||
widgetAddClasses dialog [ "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 1
|
||||
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
|
||||
choice <- GTK.dialogRun dialog
|
||||
GTK.widgetDestroy dialog
|
||||
case choice of
|
||||
JustClose -> case close of
|
||||
CloseActive -> removeFileTab fileBar vars documentUnique
|
||||
CloseThis _ destroyTab -> do
|
||||
destroyTab
|
||||
STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete documentUnique )
|
||||
SaveAndClose -> saveAs uiElts vars False doc
|
||||
_ -> pure ()
|
||||
Nothing -> pure () -- could show a warning message
|
||||
Just doc@( Document { displayName, documentUnique, unsavedChanges } )
|
||||
| unsavedChanges
|
||||
-> do
|
||||
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 [ "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 1
|
||||
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
|
||||
choice <- GTK.dialogRun dialog
|
||||
GTK.widgetDestroy dialog
|
||||
case choice of
|
||||
JustClose -> removeFileTab window title viewportDrawingArea infoBar vars documentUnique
|
||||
SaveAndClose -> saveAs uiElts vars False doc
|
||||
_ -> pure ()
|
||||
| otherwise
|
||||
-> removeFileTab window title viewportDrawingArea infoBar vars documentUnique
|
||||
|
||||
---------------------
|
||||
-- Switch document --
|
||||
---------------------
|
||||
|
||||
data SwitchTo = SwitchTo Unique
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction SwitchTo where
|
||||
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( SwitchTo newUnique ) = do
|
||||
mbNewDocAndTab <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
|
||||
newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
|
||||
pure ( (,) <$> newDoc <*> newTab )
|
||||
case mbNewDocAndTab of
|
||||
Nothing -> updateTitle window title Nothing
|
||||
Just ( Document { .. }, tab ) -> do
|
||||
updateTitle window title ( Just ( displayName, unsavedChanges ) )
|
||||
updateInfoBar viewportDrawingArea infoBar vars
|
||||
GTK.widgetQueueDraw tab
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
--------------
|
||||
-- Quitting --
|
||||
|
|
@ -402,7 +418,7 @@ data Delete = Delete
|
|||
|
||||
instance HandleAction Delete where
|
||||
handleAction
|
||||
( UIElements { viewportDrawingArea } )
|
||||
uiElts
|
||||
vars@( Variables { toolTVar, modeTVar } )
|
||||
_
|
||||
= do
|
||||
|
|
@ -410,9 +426,7 @@ instance HandleAction Delete where
|
|||
mode <- STM.readTVarIO modeTVar
|
||||
case tool of
|
||||
-- Delete selected points on pressing 'Delete'.
|
||||
Selection -> do
|
||||
STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
Selection -> modifyingCurrentDocument uiElts vars ( pure . Just . deleteSelected mode )
|
||||
_ -> pure ()
|
||||
|
||||
------------
|
||||
|
|
@ -497,7 +511,7 @@ data MouseClick = MouseClick Word32 ( Point2D Double )
|
|||
|
||||
instance HandleAction MouseClick where
|
||||
handleAction
|
||||
( UIElements { viewportDrawingArea } )
|
||||
uiElts@( UIElements { viewportDrawingArea } )
|
||||
vars@( Variables { .. } )
|
||||
( MouseClick button mouseClickCoords )
|
||||
= case button of
|
||||
|
|
@ -506,7 +520,7 @@ instance HandleAction MouseClick where
|
|||
1 -> do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
|
|
@ -557,7 +571,6 @@ instance HandleAction MouseClick where
|
|||
Just pp -> do
|
||||
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
||||
pure Nothing
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
-- Right mouse button: end partial path.
|
||||
3 -> do
|
||||
|
|
@ -577,7 +590,7 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
|||
|
||||
instance HandleAction MouseRelease where
|
||||
handleAction
|
||||
( UIElements { viewportDrawingArea } )
|
||||
uiElts@( UIElements { viewportDrawingArea } )
|
||||
vars@( Variables { .. } )
|
||||
( MouseRelease button ( Point2D x y ) )
|
||||
= case button of
|
||||
|
|
@ -586,7 +599,7 @@ instance HandleAction MouseRelease where
|
|||
1 -> do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
STM.atomically $ modifyingCurrentDocument vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
|
|
@ -691,8 +704,6 @@ instance HandleAction MouseRelease where
|
|||
]
|
||||
pure ( Just $ addToAnchor anchor newSegment doc )
|
||||
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
-- Other mouse buttons: ignored (for the moment at least).
|
||||
_ -> pure ()
|
||||
|
||||
|
|
@ -704,13 +715,13 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
|
|||
deriving stock Show
|
||||
|
||||
instance HandleAction Scroll where
|
||||
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
|
||||
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
|
||||
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
|
||||
unless ( dx == 0 && dy == 0 ) do
|
||||
STM.atomically $ modifyingCurrentDocument vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
|
|
@ -757,7 +768,6 @@ instance HandleAction Scroll where
|
|||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||
pure ( Just newDoc )
|
||||
updateInfoBar viewportDrawingArea infoBar vars
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
--------------------
|
||||
-- Keyboard press --
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module MetaBrush.Context
|
||||
|
|
@ -7,12 +9,17 @@ module MetaBrush.Context
|
|||
, LR(..), Modifier(..), modifierKey, modifierType
|
||||
, HoldAction(..), PartialPath(..)
|
||||
, currentDocument, withCurrentDocument, modifyingCurrentDocument
|
||||
, updateTitle
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( join )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
( for_, sequenceA_ )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
|
|
@ -33,14 +40,20 @@ import qualified GI.Gtk as GTK
|
|||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar, readTVar, readTVar, writeTVar )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D )
|
||||
import MetaBrush.Document
|
||||
( Document )
|
||||
( Document(..) )
|
||||
import MetaBrush.Document.Draw
|
||||
( DrawAnchor )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
|
|
@ -77,6 +90,7 @@ data Variables
|
|||
, toolTVar :: !( STM.TVar Tool )
|
||||
, modeTVar :: !( STM.TVar Mode )
|
||||
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
|
||||
, fileBarTabsTVar :: !( STM.TVar ( Map Unique GTK.Box ) )
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -142,14 +156,34 @@ withCurrentDocument vars f = traverse f =<< currentDocument vars
|
|||
-- | Modify the currently active document.
|
||||
--
|
||||
-- Does nothing if no document is currently active.
|
||||
modifyingCurrentDocument :: Variables -> ( Document -> STM ( Maybe Document ) ) -> STM ()
|
||||
modifyingCurrentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) f = do
|
||||
mbUnique <- STM.readTVar activeDocumentTVar
|
||||
case mbUnique of
|
||||
Nothing -> pure ()
|
||||
Just unique -> do
|
||||
modifyingCurrentDocument :: UIElements -> Variables -> ( Document -> STM ( Maybe Document ) ) -> IO ()
|
||||
modifyingCurrentDocument ( UIElements { .. } ) ( Variables { .. } ) f = do
|
||||
mbActions <- STM.atomically do
|
||||
mbUnique <- STM.readTVar activeDocumentTVar
|
||||
for mbUnique \ unique -> do
|
||||
docs <- STM.readTVar openDocumentsTVar
|
||||
for_ ( Map.lookup unique docs ) \ oldDoc -> do
|
||||
mbNewDoc <- f oldDoc
|
||||
for_ mbNewDoc \ newDoc -> do
|
||||
STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )
|
||||
mbUpdateTitleAction <-
|
||||
join <$> for ( Map.lookup unique docs ) \ oldDoc -> do
|
||||
mbNewDoc <- f oldDoc
|
||||
for mbNewDoc \ newDoc -> do
|
||||
STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )
|
||||
pure do
|
||||
updateTitle window title $ Just ( displayName newDoc, unsavedChanges newDoc )
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
mbActiveTab <- Map.lookup unique <$> STM.readTVar fileBarTabsTVar
|
||||
pure ( for_ mbActiveTab GTK.widgetQueueDraw *> sequenceA_ mbUpdateTitleAction )
|
||||
sequenceA_ mbActions
|
||||
|
||||
updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
|
||||
updateTitle window title mbTitleText = do
|
||||
GTK.labelSetText title titleText
|
||||
GTK.setWindowTitle window titleText
|
||||
where
|
||||
titleText :: Text
|
||||
titleText = case mbTitleText of
|
||||
Nothing -> "MetaBrush"
|
||||
Just ( name, hasUnsavedChanges )
|
||||
| hasUnsavedChanges
|
||||
-> "● " <> name <> " – MetaBrush"
|
||||
| otherwise
|
||||
-> name <> " – MetaBrush"
|
||||
|
|
|
|||
|
|
@ -14,25 +14,16 @@ module MetaBrush.UI.FileBar
|
|||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( unless, void, when )
|
||||
import Data.Maybe
|
||||
( listToMaybe )
|
||||
( join, void )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import qualified Foreign.Marshal.Alloc as Foreign
|
||||
( malloc, free )
|
||||
import qualified Foreign.Ptr as Foreign
|
||||
( castPtr, nullPtr )
|
||||
import qualified Foreign.Storable as Foreign
|
||||
( peek, poke )
|
||||
( for_, sequenceA_ )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map.Strict as Map
|
||||
( lookup, insert, delete )
|
||||
|
||||
-- gi-gobject
|
||||
import qualified GI.GObject as GObject
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
|
|
@ -40,17 +31,15 @@ import qualified GI.Gtk as GTK
|
|||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( writeTVar, readTVarIO, modifyTVar' )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
( writeTVar, readTVar, readTVarIO, modifyTVar' )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
( Close(..), handleAction )
|
||||
( SwitchTo(..), Close(..), handleAction )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
( UIElements(..), Variables(..)
|
||||
, updateTitle
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..), emptyDocument )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
|
|
@ -59,7 +48,7 @@ import MetaBrush.Unique
|
|||
( Unique, freshUnique, uniqueText )
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses
|
||||
, (>>?=), Exists(..)
|
||||
, Exists(..)
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -83,7 +72,7 @@ newFileTab
|
|||
-> TabLocation
|
||||
-> IO ()
|
||||
newFileTab
|
||||
vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } )
|
||||
vars@( Variables { .. } )
|
||||
uiElts@( UIElements { fileBar = FileBar {..}, .. } )
|
||||
mbDoc
|
||||
newTabLoc
|
||||
|
|
@ -113,35 +102,22 @@ newFileTab
|
|||
widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
|
||||
GTK.widgetShowAll tab
|
||||
|
||||
-- Associate each tab with the corresponding document unique,
|
||||
-- so we can know which document corresponds to each file tab
|
||||
-- by only looking at the tab.
|
||||
let
|
||||
newUnique :: Unique
|
||||
newUnique = documentUnique newDoc
|
||||
uniquePtr <- Foreign.malloc @Unique
|
||||
Foreign.poke uniquePtr newUnique
|
||||
GObject.objectSetData tab "unique" ( Foreign.castPtr @Unique @() uniquePtr )
|
||||
|
||||
-- We've placed the new tab at the end. Now rearrange it if needed.
|
||||
case newTabLoc of
|
||||
LastTab -> pure ()
|
||||
AfterCurrentTab -> do
|
||||
children <- GTK.containerGetChildren fileTabsBox
|
||||
for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
|
||||
mbBox <- GTK.castTo GTK.Box childWidget
|
||||
for_ mbBox \ box -> do
|
||||
mbButton
|
||||
<- ( listToMaybe <$> GTK.containerGetChildren box )
|
||||
>>?= GTK.castTo GTK.RadioButton
|
||||
for_ mbButton \ button -> do
|
||||
isActive <- GTK.toggleButtonGetActive button
|
||||
if isActive
|
||||
then
|
||||
GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
|
||||
else
|
||||
pure ()
|
||||
|
||||
mbActiveTab <- fmap join $ STM.atomically do
|
||||
mbUnique <- STM.readTVar activeDocumentTVar
|
||||
for mbUnique \ docUnique -> do
|
||||
Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
for_ mbActiveTab \ activeTab -> do
|
||||
children <- GTK.containerGetChildren fileTabsBox
|
||||
for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
|
||||
mbBox <- GTK.castTo GTK.Box childWidget
|
||||
for_ mbBox \ box ->
|
||||
if box == activeTab
|
||||
then GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
|
||||
else pure ()
|
||||
|
||||
-- Ensure consistency of hover/selection state between the two elements in the tab.
|
||||
for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
|
||||
|
|
@ -155,10 +131,14 @@ newFileTab
|
|||
pure False
|
||||
|
||||
-- Update the state: switch to this new document.
|
||||
|
||||
let
|
||||
newUnique :: Unique
|
||||
newUnique = documentUnique newDoc
|
||||
STM.atomically do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
|
||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique tab )
|
||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
void $ GTK.onButtonClicked pgButton do
|
||||
|
|
@ -167,24 +147,8 @@ newFileTab
|
|||
if isActive
|
||||
then do
|
||||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
|
||||
STM.atomically ( STM.writeTVar activeDocumentTVar ( Just newUnique ) )
|
||||
mbActiveDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
|
||||
case mbActiveDoc of
|
||||
Nothing -> do
|
||||
GTK.labelSetText title "MetaBrush"
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
Just ( Document { .. } ) -> do
|
||||
let
|
||||
titleText :: Text
|
||||
titleText
|
||||
| unsavedChanges
|
||||
= "● " <> displayName <> " – MetaBrush"
|
||||
| otherwise
|
||||
= displayName <> " – MetaBrush"
|
||||
GTK.labelSetText title titleText
|
||||
GTK.setWindowTitle window titleText
|
||||
updateInfoBar viewportDrawingArea infoBar vars
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
handleAction uiElts vars
|
||||
( SwitchTo newUnique )
|
||||
else do
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||
GTK.labelSetText title "MetaBrush"
|
||||
|
|
@ -192,7 +156,7 @@ newFileTab
|
|||
|
||||
void $ GTK.onButtonClicked closeFileButton
|
||||
( handleAction uiElts vars
|
||||
( CloseThis newUnique ( Foreign.free uniquePtr *> GTK.widgetDestroy tab ) )
|
||||
( CloseThis newUnique )
|
||||
)
|
||||
|
||||
GTK.toggleButtonSetActive pgButton True
|
||||
|
|
@ -254,15 +218,29 @@ createFileBar
|
|||
pure fileBar
|
||||
|
||||
-- | Close a document: remove the corresponding file tab from the file bar.
|
||||
removeFileTab :: FileBar -> Variables -> Unique -> IO ()
|
||||
removeFileTab ( FileBar { fileTabsBox } ) ( Variables { openDocumentsTVar } ) docUnique = do
|
||||
GTK.containerForeach fileTabsBox \ tab -> do
|
||||
removeFileTab :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables -> Unique -> IO ()
|
||||
removeFileTab window title viewportDrawingArea infoBar vars@( Variables { .. } ) docUnique = do
|
||||
|
||||
uniquePtr <- Foreign.castPtr @() @Unique <$> GObject.objectGetData tab "unique"
|
||||
unless ( uniquePtr == Foreign.nullPtr ) do
|
||||
tabUnique <- Foreign.peek uniquePtr
|
||||
when ( docUnique == tabUnique ) do
|
||||
Foreign.free uniquePtr
|
||||
GTK.widgetDestroy tab
|
||||
cleanupActions <- STM.atomically do
|
||||
-- Remove the tab.
|
||||
mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
mbAction1 <- for mbTab \ tab -> do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique )
|
||||
pure ( GTK.widgetDestroy tab )
|
||||
|
||||
STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
|
||||
-- Update title and drawing area if we closed the active document.
|
||||
mbActiveUnique <- STM.readTVar activeDocumentTVar
|
||||
mbAction2 <- for mbActiveUnique \ activeUnique ->
|
||||
if activeUnique == docUnique
|
||||
then do
|
||||
STM.writeTVar activeDocumentTVar Nothing
|
||||
pure do
|
||||
updateTitle window title Nothing
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
updateInfoBar viewportDrawingArea infoBar vars
|
||||
else pure ( pure () )
|
||||
|
||||
|
||||
pure ( sequenceA_ mbAction1 *> sequenceA_ mbAction2 )
|
||||
cleanupActions
|
||||
|
|
|
|||
|
|
@ -40,4 +40,4 @@ createFileBar
|
|||
|
||||
newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO ()
|
||||
|
||||
removeFileTab :: FileBar -> Variables -> Unique -> IO ()
|
||||
removeFileTab :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables -> Unique -> IO ()
|
||||
|
|
|
|||
Loading…
Reference in a new issue