hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +00:00
Code Issues Actions Projects Releases Wiki Activity

update title and file tab upon change, close

Browse source
This commit is contained in:
sheaf 2020-09-04 20:54:48 +02:00
parent 341a8ed0ca
commit 86729cb462
5 changed files with 172 additions and 147 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
app/Main.hs
View file

@ -21,6 +21,8 @@ import System.Exit
-- containers -- containers
import Data.Map.Strict import Data.Map.Strict
( Map ) ( Map )
import qualified Data.Map.Strict as Map
( empty )
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -187,6 +189,7 @@ main = do
toolTVar <- STM.newTVarIO @Tool Selection toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path modeTVar <- STM.newTVarIO @Mode Path
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing 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. -- Put all these stateful variables in a record for conciseness.
let let

82
src/app/MetaBrush/Action.hs
View file

@ -36,7 +36,7 @@ import Data.Act
-- containers -- containers
import qualified Data.Map as Map import qualified Data.Map as Map
( lookup, insert, delete ) ( lookup, insert )
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -76,6 +76,7 @@ import MetaBrush.Context
, Modifier(..), modifierKey , Modifier(..), modifierKey
, HoldAction(..), PartialPath(..) , HoldAction(..), PartialPath(..)
, currentDocument, withCurrentDocument, modifyingCurrentDocument , currentDocument, withCurrentDocument, modifyingCurrentDocument
, updateTitle
) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ( Document(..)
@ -227,7 +228,7 @@ instance HandleAction SaveAs where
Just doc -> saveAs uiElts vars True doc Just doc -> saveAs uiElts vars True doc
saveAs :: UIElements -> Variables -> Bool -> Document -> IO () 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 <- fileChooser <-
GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window ) GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
GTK.FileChooserActionSave GTK.FileChooserActionSave
@ -258,7 +259,7 @@ saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar }
( Map.insert ( documentUnique doc ) ( Map.insert ( documentUnique doc )
( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } ) ( doc { mbFilePath = Just fullFilePath, unsavedChanges = False } )
) )
else removeFileTab fileBar vars ( documentUnique doc ) else removeFileTab window title viewportDrawingArea infoBar vars ( documentUnique doc )
----------- -----------
-- Close -- -- Close --
@ -266,14 +267,9 @@ saveAs ( UIElements { window, fileBar } ) vars@( Variables { openDocumentsTVar }
data Close data Close
= CloseActive -- ^ Close active document. = CloseActive -- ^ Close active document.
| CloseThis -- ^ Close a specific tab (action to destroy tab is directly given). | CloseThis -- ^ Close a specific tab.
{ docToClose :: Unique { docToClose :: Unique }
, destroyTabAction :: IO () deriving stock Show
}
instance Show Close where
show CloseActive = "CloseActive"
show ( CloseThis docToClose _ ) = "CloseThis " <> show docToClose
pattern JustClose, SaveAndClose, CancelClose :: Int32 pattern JustClose, SaveAndClose, CancelClose :: Int32
pattern JustClose = 1 pattern JustClose = 1
@ -281,20 +277,20 @@ pattern SaveAndClose = 2
pattern CancelClose = 3 pattern CancelClose = 3
instance HandleAction Close where instance HandleAction Close where
handleAction uiElts@( UIElements { window, fileBar } ) vars@( Variables { .. } ) close = do handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do
mbDoc <- case close of mbDoc <- case close of
CloseActive -> STM.atomically $ currentDocument vars CloseActive -> STM.atomically ( currentDocument vars )
CloseThis unique _ -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
case mbDoc of case mbDoc of
Nothing -> pure () -- could show a warning message Nothing -> pure () -- could show a warning message
Just doc@( Document { displayName, documentUnique } ) -> do Just doc@( Document { displayName, documentUnique, unsavedChanges } )
| unsavedChanges
-> do
dialog <- GTK.new GTK.MessageDialog [] dialog <- GTK.new GTK.MessageDialog []
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" ) GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
GTK.setWindowResizable dialog False GTK.setWindowResizable dialog False
GTK.setWindowDecorated dialog False GTK.setWindowDecorated dialog False
GTK.widgetAddEvents dialog
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
GTK.windowSetTransientFor dialog ( Just window ) GTK.windowSetTransientFor dialog ( Just window )
GTK.windowSetModal dialog True GTK.windowSetModal dialog True
widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
@ -306,13 +302,33 @@ instance HandleAction Close where
choice <- GTK.dialogRun dialog choice <- GTK.dialogRun dialog
GTK.widgetDestroy dialog GTK.widgetDestroy dialog
case choice of case choice of
JustClose -> case close of JustClose -> removeFileTab window title viewportDrawingArea infoBar vars documentUnique
CloseActive -> removeFileTab fileBar vars documentUnique
CloseThis _ destroyTab -> do
destroyTab
STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete documentUnique )
SaveAndClose -> saveAs uiElts vars False doc SaveAndClose -> saveAs uiElts vars False doc
_ -> pure () _ -> 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 -- -- Quitting --
@ -402,7 +418,7 @@ data Delete = Delete
instance HandleAction Delete where instance HandleAction Delete where
handleAction handleAction
( UIElements { viewportDrawingArea } ) uiElts
vars@( Variables { toolTVar, modeTVar } ) vars@( Variables { toolTVar, modeTVar } )
_ _
= do = do
@ -410,9 +426,7 @@ instance HandleAction Delete where
mode <- STM.readTVarIO modeTVar mode <- STM.readTVarIO modeTVar
case tool of case tool of
-- Delete selected points on pressing 'Delete'. -- Delete selected points on pressing 'Delete'.
Selection -> do Selection -> modifyingCurrentDocument uiElts vars ( pure . Just . deleteSelected mode )
STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
GTK.widgetQueueDraw viewportDrawingArea
_ -> pure () _ -> pure ()
------------ ------------
@ -497,7 +511,7 @@ data MouseClick = MouseClick Word32 ( Point2D Double )
instance HandleAction MouseClick where instance HandleAction MouseClick where
handleAction handleAction
( UIElements { viewportDrawingArea } ) uiElts@( UIElements { viewportDrawingArea } )
vars@( Variables { .. } ) vars@( Variables { .. } )
( MouseClick button mouseClickCoords ) ( MouseClick button mouseClickCoords )
= case button of = case button of
@ -506,7 +520,7 @@ instance HandleAction MouseClick where
1 -> do 1 -> do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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 let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
@ -557,7 +571,6 @@ instance HandleAction MouseClick where
Just pp -> do Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Nothing pure Nothing
GTK.widgetQueueDraw viewportDrawingArea
-- Right mouse button: end partial path. -- Right mouse button: end partial path.
3 -> do 3 -> do
@ -577,7 +590,7 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double )
instance HandleAction MouseRelease where instance HandleAction MouseRelease where
handleAction handleAction
( UIElements { viewportDrawingArea } ) uiElts@( UIElements { viewportDrawingArea } )
vars@( Variables { .. } ) vars@( Variables { .. } )
( MouseRelease button ( Point2D x y ) ) ( MouseRelease button ( Point2D x y ) )
= case button of = case button of
@ -586,7 +599,7 @@ instance HandleAction MouseRelease where
1 -> do 1 -> do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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 let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
@ -691,8 +704,6 @@ instance HandleAction MouseRelease where
] ]
pure ( Just $ addToAnchor anchor newSegment doc ) pure ( Just $ addToAnchor anchor newSegment doc )
GTK.widgetQueueDraw viewportDrawingArea
-- Other mouse buttons: ignored (for the moment at least). -- Other mouse buttons: ignored (for the moment at least).
_ -> pure () _ -> pure ()
@ -704,13 +715,13 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
deriving stock Show deriving stock Show
instance HandleAction Scroll where 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 viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
unless ( dx == 0 && dy == 0 ) do 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 modifiers <- STM.readTVar modifiersTVar
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
@ -757,7 +768,6 @@ instance HandleAction Scroll where
STM.writeTVar mousePosTVar ( Just finalMousePos ) STM.writeTVar mousePosTVar ( Just finalMousePos )
pure ( Just newDoc ) pure ( Just newDoc )
updateInfoBar viewportDrawingArea infoBar vars updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea
-------------------- --------------------
-- Keyboard press -- -- Keyboard press --

52
src/app/MetaBrush/Context.hs
View file

@ -1,5 +1,7 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
module MetaBrush.Context module MetaBrush.Context
@ -7,12 +9,17 @@ module MetaBrush.Context
, LR(..), Modifier(..), modifierKey, modifierType , LR(..), Modifier(..), modifierKey, modifierType
, HoldAction(..), PartialPath(..) , HoldAction(..), PartialPath(..)
, currentDocument, withCurrentDocument, modifyingCurrentDocument , currentDocument, withCurrentDocument, modifyingCurrentDocument
, updateTitle
) )
where where
-- base -- base
import Control.Monad
( join )
import Data.Foldable import Data.Foldable
( for_ ) ( for_, sequenceA_ )
import Data.Traversable
( for )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
@ -33,14 +40,20 @@ import qualified GI.Gtk as GTK
-- stm -- stm
import Control.Concurrent.STM import Control.Concurrent.STM
( STM ) ( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVar, writeTVar ) ( TVar, readTVar, readTVar, writeTVar )
-- text
import Data.Text
( Text )
-- MetaBrush -- MetaBrush
import Math.Vector2D import Math.Vector2D
( Point2D ) ( Point2D )
import MetaBrush.Document import MetaBrush.Document
( Document ) ( Document(..) )
import MetaBrush.Document.Draw import MetaBrush.Document.Draw
( DrawAnchor ) ( DrawAnchor )
import {-# SOURCE #-} MetaBrush.UI.FileBar import {-# SOURCE #-} MetaBrush.UI.FileBar
@ -77,6 +90,7 @@ data Variables
, toolTVar :: !( STM.TVar Tool ) , toolTVar :: !( STM.TVar Tool )
, modeTVar :: !( STM.TVar Mode ) , modeTVar :: !( STM.TVar Mode )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , 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. -- | Modify the currently active document.
-- --
-- Does nothing if no document is currently active. -- Does nothing if no document is currently active.
modifyingCurrentDocument :: Variables -> ( Document -> STM ( Maybe Document ) ) -> STM () modifyingCurrentDocument :: UIElements -> Variables -> ( Document -> STM ( Maybe Document ) ) -> IO ()
modifyingCurrentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) f = do modifyingCurrentDocument ( UIElements { .. } ) ( Variables { .. } ) f = do
mbActions <- STM.atomically do
mbUnique <- STM.readTVar activeDocumentTVar mbUnique <- STM.readTVar activeDocumentTVar
case mbUnique of for mbUnique \ unique -> do
Nothing -> pure ()
Just unique -> do
docs <- STM.readTVar openDocumentsTVar docs <- STM.readTVar openDocumentsTVar
for_ ( Map.lookup unique docs ) \ oldDoc -> do mbUpdateTitleAction <-
join <$> for ( Map.lookup unique docs ) \ oldDoc -> do
mbNewDoc <- f oldDoc mbNewDoc <- f oldDoc
for_ mbNewDoc \ newDoc -> do for mbNewDoc \ newDoc -> do
STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs ) 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"

126
src/app/MetaBrush/UI/FileBar.hs
View file

@ -14,25 +14,16 @@ module MetaBrush.UI.FileBar
-- base -- base
import Control.Monad import Control.Monad
( unless, void, when ) ( join, void )
import Data.Maybe
( listToMaybe )
import Data.Foldable import Data.Foldable
( for_ ) ( for_, sequenceA_ )
import qualified Foreign.Marshal.Alloc as Foreign import Data.Traversable
( malloc, free ) ( for )
import qualified Foreign.Ptr as Foreign
( castPtr, nullPtr )
import qualified Foreign.Storable as Foreign
( peek, poke )
-- containers -- containers
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
( lookup, insert, delete ) ( lookup, insert, delete )
-- gi-gobject
import qualified GI.GObject as GObject
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
@ -40,17 +31,15 @@ import qualified GI.Gtk as GTK
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( writeTVar, readTVarIO, modifyTVar' ) ( writeTVar, readTVar, readTVarIO, modifyTVar' )
-- text
import Data.Text
( Text )
-- MetaBrush -- MetaBrush
import MetaBrush.Action import MetaBrush.Action
( Close(..), handleAction ) ( SwitchTo(..), Close(..), handleAction )
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ) ( UIElements(..), Variables(..)
, updateTitle
)
import MetaBrush.Document import MetaBrush.Document
( Document(..), emptyDocument ) ( Document(..), emptyDocument )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
@ -59,7 +48,7 @@ import MetaBrush.Unique
( Unique, freshUnique, uniqueText ) ( Unique, freshUnique, uniqueText )
import MetaBrush.Util import MetaBrush.Util
( widgetAddClass, widgetAddClasses ( widgetAddClass, widgetAddClasses
, (>>?=), Exists(..) , Exists(..)
) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -83,7 +72,7 @@ newFileTab
-> TabLocation -> TabLocation
-> IO () -> IO ()
newFileTab newFileTab
vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } ) vars@( Variables { .. } )
uiElts@( UIElements { fileBar = FileBar {..}, .. } ) uiElts@( UIElements { fileBar = FileBar {..}, .. } )
mbDoc mbDoc
newTabLoc newTabLoc
@ -113,35 +102,22 @@ newFileTab
widgetAddClasses closeFileButton [ "fileBarCloseButton" ] widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
GTK.widgetShowAll tab 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. -- We've placed the new tab at the end. Now rearrange it if needed.
case newTabLoc of case newTabLoc of
LastTab -> pure () LastTab -> pure ()
AfterCurrentTab -> do AfterCurrentTab -> do
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 children <- GTK.containerGetChildren fileTabsBox
for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
mbBox <- GTK.castTo GTK.Box childWidget mbBox <- GTK.castTo GTK.Box childWidget
for_ mbBox \ box -> do for_ mbBox \ box ->
mbButton if box == activeTab
<- ( listToMaybe <$> GTK.containerGetChildren box ) then GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
>>?= GTK.castTo GTK.RadioButton else pure ()
for_ mbButton \ button -> do
isActive <- GTK.toggleButtonGetActive button
if isActive
then
GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
else
pure ()
-- Ensure consistency of hover/selection state between the two elements in the tab. -- 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 for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
@ -155,10 +131,14 @@ newFileTab
pure False pure False
-- Update the state: switch to this new document. -- Update the state: switch to this new document.
let
newUnique :: Unique
newUnique = documentUnique newDoc
STM.atomically do STM.atomically do
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc ) STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique tab )
STM.writeTVar activeDocumentTVar ( Just newUnique ) STM.writeTVar activeDocumentTVar ( Just newUnique )
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
void $ GTK.onButtonClicked pgButton do void $ GTK.onButtonClicked pgButton do
@ -167,24 +147,8 @@ newFileTab
if isActive if isActive
then do then do
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
STM.atomically ( STM.writeTVar activeDocumentTVar ( Just newUnique ) ) handleAction uiElts vars
mbActiveDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar ( SwitchTo newUnique )
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
else do else do
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
GTK.labelSetText title "MetaBrush" GTK.labelSetText title "MetaBrush"
@ -192,7 +156,7 @@ newFileTab
void $ GTK.onButtonClicked closeFileButton void $ GTK.onButtonClicked closeFileButton
( handleAction uiElts vars ( handleAction uiElts vars
( CloseThis newUnique ( Foreign.free uniquePtr *> GTK.widgetDestroy tab ) ) ( CloseThis newUnique )
) )
GTK.toggleButtonSetActive pgButton True GTK.toggleButtonSetActive pgButton True
@ -254,15 +218,29 @@ createFileBar
pure fileBar pure fileBar
-- | Close a document: remove the corresponding file tab from the file bar. -- | Close a document: remove the corresponding file tab from the file bar.
removeFileTab :: FileBar -> Variables -> Unique -> IO () removeFileTab :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables -> Unique -> IO ()
removeFileTab ( FileBar { fileTabsBox } ) ( Variables { openDocumentsTVar } ) docUnique = do removeFileTab window title viewportDrawingArea infoBar vars@( Variables { .. } ) docUnique = do
GTK.containerForeach fileTabsBox \ tab -> do
uniquePtr <- Foreign.castPtr @() @Unique <$> GObject.objectGetData tab "unique" cleanupActions <- STM.atomically do
unless ( uniquePtr == Foreign.nullPtr ) do -- Remove the tab.
tabUnique <- Foreign.peek uniquePtr mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
when ( docUnique == tabUnique ) do mbAction1 <- for mbTab \ tab -> do
Foreign.free uniquePtr STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
GTK.widgetDestroy tab 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

2
src/app/MetaBrush/UI/FileBar.hs-boot
View file

@ -40,4 +40,4 @@ createFileBar
newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO () newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO ()
removeFileTab :: FileBar -> Variables -> Unique -> IO () removeFileTab :: GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar -> Variables -> Unique -> IO ()