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:
parent
341a8ed0ca
commit
86729cb462
|
@ -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
|
||||||
|
|
|
@ -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,38 +277,58 @@ 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 } )
|
||||||
dialog <- GTK.new GTK.MessageDialog []
|
| unsavedChanges
|
||||||
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
|
-> do
|
||||||
GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
|
dialog <- GTK.new GTK.MessageDialog []
|
||||||
GTK.setWindowResizable dialog False
|
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
|
||||||
GTK.setWindowDecorated dialog False
|
GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
|
||||||
GTK.widgetAddEvents dialog
|
GTK.setWindowResizable dialog False
|
||||||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
GTK.setWindowDecorated dialog False
|
||||||
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" ]
|
||||||
closeButton <- GTK.dialogAddButton dialog "Close" JustClose
|
closeButton <- GTK.dialogAddButton dialog "Close" JustClose
|
||||||
saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
|
saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
|
||||||
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
|
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
|
||||||
GTK.dialogSetDefaultResponse dialog 1
|
GTK.dialogSetDefaultResponse dialog 1
|
||||||
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
|
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
|
||||||
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
|
SaveAndClose -> saveAs uiElts vars False doc
|
||||||
CloseThis _ destroyTab -> do
|
_ -> pure ()
|
||||||
destroyTab
|
| otherwise
|
||||||
STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete documentUnique )
|
-> removeFileTab window title viewportDrawingArea infoBar vars documentUnique
|
||||||
SaveAndClose -> saveAs uiElts vars False doc
|
|
||||||
_ -> pure ()
|
---------------------
|
||||||
|
-- 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 --
|
||||||
|
|
|
@ -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
|
||||||
mbUnique <- STM.readTVar activeDocumentTVar
|
mbActions <- STM.atomically do
|
||||||
case mbUnique of
|
mbUnique <- STM.readTVar activeDocumentTVar
|
||||||
Nothing -> pure ()
|
for mbUnique \ unique -> do
|
||||||
Just unique -> do
|
|
||||||
docs <- STM.readTVar openDocumentsTVar
|
docs <- STM.readTVar openDocumentsTVar
|
||||||
for_ ( Map.lookup unique docs ) \ oldDoc -> do
|
mbUpdateTitleAction <-
|
||||||
mbNewDoc <- f oldDoc
|
join <$> for ( Map.lookup unique docs ) \ oldDoc -> do
|
||||||
for_ mbNewDoc \ newDoc -> do
|
mbNewDoc <- f oldDoc
|
||||||
STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )
|
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
|
-- 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
|
||||||
children <- GTK.containerGetChildren fileTabsBox
|
mbActiveTab <- fmap join $ STM.atomically do
|
||||||
for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
|
mbUnique <- STM.readTVar activeDocumentTVar
|
||||||
mbBox <- GTK.castTo GTK.Box childWidget
|
for mbUnique \ docUnique -> do
|
||||||
for_ mbBox \ box -> do
|
Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||||
mbButton
|
for_ mbActiveTab \ activeTab -> do
|
||||||
<- ( listToMaybe <$> GTK.containerGetChildren box )
|
children <- GTK.containerGetChildren fileTabsBox
|
||||||
>>?= GTK.castTo GTK.RadioButton
|
for_ ( zip children [0..] ) \ ( childWidget, activeTabIndex ) -> do
|
||||||
for_ mbButton \ button -> do
|
mbBox <- GTK.castTo GTK.Box childWidget
|
||||||
isActive <- GTK.toggleButtonGetActive button
|
for_ mbBox \ box ->
|
||||||
if isActive
|
if box == activeTab
|
||||||
then
|
then GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
|
||||||
GTK.boxReorderChild fileTabsBox tab ( activeTabIndex + 1 )
|
else pure ()
|
||||||
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.writeTVar activeDocumentTVar ( Just newUnique )
|
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique tab )
|
||||||
|
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 )
|
||||||
|
|
||||||
|
-- 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 () )
|
||||||
|
|
||||||
STM.atomically $ STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
|
|
||||||
|
pure ( sequenceA_ mbAction1 *> sequenceA_ mbAction2 )
|
||||||
|
cleanupActions
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
Loading…
Reference in a new issue