update file tabs dynamically

This commit is contained in:
sheaf 2020-09-01 21:56:59 +02:00
parent 8a6b4f5391
commit 101d9515c0
23 changed files with 397 additions and 309 deletions

View file

@ -109,9 +109,7 @@ executable MetaBrush
, MetaBrush.Document.Selection , MetaBrush.Document.Selection
, MetaBrush.Document.Serialise , MetaBrush.Document.Serialise
, MetaBrush.Event , MetaBrush.Event
, MetaBrush.Event.KeyCodes
, MetaBrush.Render.Document , MetaBrush.Render.Document
, MetaBrush.Render.Util
, MetaBrush.Time , MetaBrush.Time
, MetaBrush.UI.Coordinates , MetaBrush.UI.Coordinates
, MetaBrush.UI.FileBar , MetaBrush.UI.FileBar
@ -121,6 +119,7 @@ executable MetaBrush
, MetaBrush.UI.ToolBar , MetaBrush.UI.ToolBar
, MetaBrush.UI.Viewport , MetaBrush.UI.Viewport
, MetaBrush.Unique , MetaBrush.Unique
, MetaBrush.Util
, Paths_MetaBrush , Paths_MetaBrush
autogen-modules: autogen-modules:

View file

@ -22,10 +22,8 @@ import System.Exit
( exitSuccess ) ( exitSuccess )
-- containers -- containers
import Data.IntMap.Strict import Data.Map.Strict
( IntMap ) ( Map )
import qualified Data.IntMap.Strict as IntMap
( fromList )
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -65,7 +63,7 @@ import MetaBrush.Asset.Colours
import MetaBrush.Asset.Logo import MetaBrush.Asset.Logo
( drawLogo ) ( drawLogo )
import MetaBrush.Document import MetaBrush.Document
( Document(..), AABB(..), Stroke(..) ( Document(..), Stroke(..)
, FocusState(..) , FocusState(..)
, PointData(..), BrushPointData(..) , PointData(..), BrushPointData(..)
, currentDocument , currentDocument
@ -76,8 +74,6 @@ import MetaBrush.Event
) )
import MetaBrush.Render.Document import MetaBrush.Render.Document
( renderDocument ) ( renderDocument )
import MetaBrush.Render.Util
( widgetAddClass, widgetAddClasses )
import MetaBrush.UI.FileBar import MetaBrush.UI.FileBar
( createFileBar ) ( createFileBar )
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
@ -91,64 +87,65 @@ import MetaBrush.UI.ToolBar
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), createViewport ) ( Viewport(..), createViewport )
import MetaBrush.Unique import MetaBrush.Unique
( newUniqueSupply, unsafeUnique ) ( newUniqueSupply
, Unique, unsafeUnique
, uniqueMapFromList
)
import MetaBrush.Util
( widgetAddClass, widgetAddClasses )
import qualified Paths_MetaBrush as Cabal import qualified Paths_MetaBrush as Cabal
( getDataFileName ) ( getDataFileName )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
testDocuments :: IntMap Document testDocuments :: Map Unique Document
testDocuments = IntMap.fromList testDocuments = uniqueMapFromList
$ zip [0..] [ Document
[ Document { displayName = "Closed"
{ displayName = "Closed" , mbFilePath = Nothing
, mbFilePath = Nothing , unsavedChanges = False
, unsavedChanges = False , viewportCenter = Point2D 50 50
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , zoomFactor = 1
, viewportCenter = Point2D 50 50 , documentUnique = unsafeUnique 0
, zoomFactor = 1 , strokes = [ Stroke
, documentUnique = unsafeUnique 0 { strokeName = "Ellipse"
, strokes = [ Stroke , strokeVisible = True
{ strokeName = "Ellipse" , strokeUnique = unsafeUnique 10
, strokeVisible = True , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
, strokeUnique = unsafeUnique 10 }
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) ]
} }
] , Document
} { displayName = "Line"
, Document , mbFilePath = Nothing
{ displayName = "Line" , unsavedChanges = True
, mbFilePath = Nothing , viewportCenter = Point2D 0 0
, unsavedChanges = True , zoomFactor = 1
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) , documentUnique = unsafeUnique 1
, viewportCenter = Point2D 0 0 , strokes = [ Stroke
, zoomFactor = 1 { strokeName = "Line"
, documentUnique = unsafeUnique 1 , strokeVisible = True
, strokes = [ Stroke , strokeUnique = unsafeUnique 11
{ strokeName = "Line" , strokePoints = linePts
, strokeVisible = True }
, strokeUnique = unsafeUnique 11 ]
, strokePoints = linePts }
} , Document
] { displayName = "Short line"
} , mbFilePath = Nothing
, Document , unsavedChanges = False
{ displayName = "Short line" , viewportCenter = Point2D 0 0
, mbFilePath = Nothing , zoomFactor = 1
, unsavedChanges = False , documentUnique = unsafeUnique 2
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) , strokes = [ Stroke
, viewportCenter = Point2D 0 0 { strokeName = "ShortLine"
, zoomFactor = 1 , strokeVisible = True
, documentUnique = unsafeUnique 2 , strokeUnique = unsafeUnique 12
, strokes = [ Stroke , strokePoints = linePts2
{ strokeName = "ShortLine" }
, strokeVisible = True ]
, strokeUnique = unsafeUnique 12 }
, strokePoints = linePts2 ]
}
]
}
]
where where
linePts :: Seq ( StrokePoint PointData ) linePts :: Seq ( StrokePoint PointData )
linePts = Seq.fromList linePts = Seq.fromList
@ -176,8 +173,8 @@ main = do
-- Initialise state -- Initialise state
uniqueSupply <- newUniqueSupply uniqueSupply <- newUniqueSupply
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
@ -248,14 +245,9 @@ main = do
GTK.panedPack1 mainPane mainView True False GTK.panedPack1 mainPane mainView True False
GTK.panedPack2 mainPane panelBox False False GTK.panedPack2 mainPane panelBox False False
fileBar <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
viewportGrid <- GTK.gridNew viewportGrid <- GTK.gridNew
infoBar <- GTK.boxNew GTK.OrientationHorizontal 0 infoBar <- GTK.boxNew GTK.OrientationHorizontal 0
GTK.boxPackStart mainView fileBar False False 0
GTK.boxPackStart mainView viewportGrid True True 0
GTK.boxPackStart mainView infoBar False False 0
--------------------------------------------------------- ---------------------------------------------------------
-- Background -- Background
@ -327,15 +319,14 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- File bar -- File bar
_ <- fileBar <-
createFileBar createFileBar
activeDocumentTVar uniqueSupply activeDocumentTVar openDocumentsTVar
openDocumentsTVar window title viewportDrawingArea infoBarElements
window
title GTK.boxPackStart mainView fileBar False False 0
viewportDrawingArea GTK.boxPackStart mainView viewportGrid True True 0
infoBarElements GTK.boxPackStart mainView infoBar False False 0
fileBar
--------------------------------------------------------- ---------------------------------------------------------
-- Panels -- Panels

View file

@ -320,7 +320,7 @@ tooltip {
} }
.fileBarCloseButton { .fileBarCloseButton {
padding-left: 5px; padding-left: 1px;
padding-right: 5px; padding-right: 5px;
margin: 0px; margin: 0px;
color: rgba(212, 190, 152,0.2); color: rgba(212, 190, 152,0.2);
@ -330,6 +330,25 @@ tooltip {
color: rgba(213,19,36,0.9); color: rgba(213,19,36,0.9);
} }
.newFileButton {
color: rgb(72,70,61);
font-size: 16px;
font-weight: bold;
font-family: "Sans";
padding: 0px 5px 0px 4px;
margin: 3px 0px 3px 0px;
border-left: 1px solid rgb(41, 40, 40);
}
.newFileButton:hover, .newFileButton:active, .newFileButton:checked {
color: rgb(160,225,54);
}
.newFileButton:active, .newFileButton:checked {
border-color: rgb(160,225,54);
}
/* Panels */ /* Panels */
.panels { .panels {
min-width: 120px; min-width: 120px;

View file

@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( ColourRecord(..), Colours ) ( ColourRecord(..), Colours )
import MetaBrush.Render.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( ColourRecord(..), Colours ) ( ColourRecord(..), Colours )
import MetaBrush.Render.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( ColourRecord(..), Colours ) ( ColourRecord(..), Colours )
import MetaBrush.Render.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( ColourRecord(..), Colours ) ( ColourRecord(..), Colours )
import MetaBrush.Render.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( ColourRecord(..), Colours ) ( ColourRecord(..), Colours )
import MetaBrush.Render.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( ColourRecord(..), Colours ) ( ColourRecord(..), Colours )
import MetaBrush.Render.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -8,7 +8,7 @@
module MetaBrush.Document module MetaBrush.Document
( AABB(..) ( AABB(..)
, Document(..), currentDocument , Document(..), emptyDocument, currentDocument
, Stroke(..) , Stroke(..)
, PointData(..), BrushPointData(..) , PointData(..), BrushPointData(..)
, FocusState(..) , FocusState(..)
@ -16,15 +16,17 @@ module MetaBrush.Document
) )
where where
-- base
import GHC.Generics
( Generic )
-- containers -- containers
import Data.IntMap.Strict import Data.Map.Strict
( IntMap ) ( Map )
import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map
( lookup ) ( lookup )
import Data.Sequence import Data.Sequence
( Seq ) ( Seq )
import GHC.Generics
( Generic )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
@ -50,7 +52,7 @@ import qualified Control.Concurrent.STM.TVar as STM
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( StrokePoint(..) )
import Math.Vector2D import Math.Vector2D
( Point2D ) ( Point2D(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
@ -66,7 +68,6 @@ data Document
{ displayName :: !Text { displayName :: !Text
, mbFilePath :: !( Maybe FilePath ) , mbFilePath :: !( Maybe FilePath )
, unsavedChanges :: !Bool , unsavedChanges :: !Bool
, bounds :: !AABB
, viewportCenter :: !( Point2D Double ) , viewportCenter :: !( Point2D Double )
, zoomFactor :: !Double , zoomFactor :: !Double
, documentUnique :: Unique , documentUnique :: Unique
@ -107,11 +108,23 @@ _selection = field' @"pointData" . typed @FocusState
_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) ) _brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
_brush = field' @"pointData" . field' @"brushShape" _brush = field' @"pointData" . field' @"brushShape"
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document ) currentDocument :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar mbActive <- STM.readTVar activeDocumentTVar
case mbActive of case mbActive of
Nothing -> pure Nothing Nothing -> pure Nothing
Just i -> do Just unique -> do
docs <- STM.readTVar openDocumentsTVar docs <- STM.readTVar openDocumentsTVar
pure ( IntMap.lookup i docs ) pure ( Map.lookup unique docs )
emptyDocument :: Text -> Unique -> Document
emptyDocument docName unique =
Document
{ displayName = docName
, mbFilePath = Nothing
, unsavedChanges = False
, viewportCenter = Point2D 0 0
, zoomFactor = 1
, documentUnique = unique
, strokes = []
}

View file

@ -42,6 +42,9 @@ import Data.Generics.Product.Fields
import Data.Generics.Product.Typed import Data.Generics.Product.Typed
( HasType ) ( HasType )
-- gi-gdk
import qualified GI.Gdk.Constants as GDK
-- lens -- lens
import Control.Lens import Control.Lens
( view, set, over, mapped ) ( view, set, over, mapped )
@ -69,10 +72,6 @@ import MetaBrush.Document
( Document(..), Stroke(..) ( Document(..), Stroke(..)
, FocusState(..), _selection , FocusState(..), _selection
) )
import MetaBrush.Event.KeyCodes
( pattern Alt_L , pattern Alt_R
, pattern Shift_L, pattern Shift_R
)
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Mode(..) ) ( Mode(..) )
@ -96,11 +95,11 @@ instance Monoid SelectionMode where
selectionMode :: [ Word32 ] -> SelectionMode selectionMode :: [ Word32 ] -> SelectionMode
selectionMode = foldMap \case selectionMode = foldMap \case
Alt_L -> Subtract GDK.KEY_Alt_L -> Subtract
Alt_R -> Subtract GDK.KEY_Alt_R -> Subtract
Shift_L -> Add GDK.KEY_Shift_L -> Add
Shift_R -> Add GDK.KEY_Shift_R -> Add
_ -> New _ -> New
-- | Updates the selected objects on a single click selection event. -- | Updates the selected objects on a single click selection event.
selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document

View file

@ -15,12 +15,18 @@ import Data.Foldable
( toList ) ( toList )
import Data.Functor.Contravariant import Data.Functor.Contravariant
( contramap ) ( contramap )
import Data.Functor.Identity
( Identity(..) )
import Unsafe.Coerce
( unsafeCoerce ) -- Tony Morris special
-- bytestring -- bytestring
import qualified Data.ByteString as Strict import qualified Data.ByteString as Strict
( ByteString ) ( ByteString )
import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy as Lazy
( ByteString ) ( ByteString )
import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
( toLazyByteString )
-- containers -- containers
import Data.Sequence import Data.Sequence
@ -58,18 +64,29 @@ import qualified Waargonaut.Decode as JSON.Decoder
import qualified Waargonaut.Encode as JSON import qualified Waargonaut.Encode as JSON
( Encoder, Encoder' ) ( Encoder, Encoder' )
import qualified Waargonaut.Encode as JSON.Encoder import qualified Waargonaut.Encode as JSON.Encoder
( simplePureEncodeByteString ( runEncoder
, atKey', bool, list, mapLikeObj, scientific, text , atKey', bool, list, mapLikeObj, scientific, text
) )
import qualified Waargonaut.Encode.Builder as JSON.Builder
( waargonautBuilder, bsBuilder )
import qualified Waargonaut.Encode.Builder.Whitespace as JSON.Builder
( wsBuilder )
import Waargonaut.Prettier
( NumSpaces(..), IndentStep(..) )
import qualified Waargonaut.Prettier as Inline
( InlineOption(..) )
import qualified Waargonaut.Prettier as JSON
( prettyJson )
import qualified Waargonaut.Prettier as TonyMorris
( Natural )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( StrokePoint(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) --, Vector2D(..), Mat22(..) ) ( Point2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ( Document(..)
, AABB(..)
, Stroke(..) , Stroke(..)
, PointData(..) , PointData(..)
, BrushPointData(..) , BrushPointData(..)
@ -80,9 +97,21 @@ import MetaBrush.Unique
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Serialise a document to JSON (in the form of a lazy bytestring).
documentToJSON :: Document -> Lazy.ByteString documentToJSON :: Document -> Lazy.ByteString
documentToJSON = JSON.Encoder.simplePureEncodeByteString encodeDocument documentToJSON
= runIdentity
. fmap
( Lazy.ByteString.Builder.toLazyByteString
. JSON.Builder.waargonautBuilder JSON.Builder.wsBuilder JSON.Builder.bsBuilder
. JSON.prettyJson Inline.Neither ( IndentStep four ) ( NumSpaces four )
)
. JSON.Encoder.runEncoder encodeDocument
where
four :: TonyMorris.Natural
four = unsafeCoerce ( 4 :: Integer )
-- | Parse a document from JSON (given by a strict bytestring).
documentFromJSON :: UniqueSupply -> Maybe FilePath -> Strict.ByteString -> IO ( Either JSON.DecodeError Document ) documentFromJSON :: UniqueSupply -> Maybe FilePath -> Strict.ByteString -> IO ( Either JSON.DecodeError Document )
documentFromJSON uniqueSupply mfp documentFromJSON uniqueSupply mfp
= fmap ( Bifunctor.first fst ) = fmap ( Bifunctor.first fst )
@ -130,7 +159,7 @@ decodeMat22 dec =
<*> JSON.Decoder.atKey "m01" dec <*> JSON.Decoder.atKey "m01" dec
<*> JSON.Decoder.atKey "m10" dec <*> JSON.Decoder.atKey "m10" dec
<*> JSON.Decoder.atKey "m11" dec <*> JSON.Decoder.atKey "m11" dec
-}
encodeAABB :: Applicative f => JSON.Encoder f AABB encodeAABB :: Applicative f => JSON.Encoder f AABB
@ -149,7 +178,7 @@ decodeAABB = do
where where
dec :: JSON.Decoder m ( Point2D Double ) dec :: JSON.Decoder m ( Point2D Double )
dec = decodePoint2D decodeDouble dec = decodePoint2D decodeDouble
-}
encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d ) encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d )
@ -242,9 +271,8 @@ decodeStroke uniqueSupply = do
encodeDocument :: Applicative f => JSON.Encoder f Document encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, bounds, viewportCenter, zoomFactor, strokes } ) -> encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "bounds" encodeAABB bounds
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter . JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor . JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
@ -255,9 +283,8 @@ decodeDocument uniqueSupply mbFilePath = do
let let
unsavedChanges :: Bool unsavedChanges :: Bool
unsavedChanges = False unsavedChanges = False
bounds <- JSON.Decoder.atKey "bounds" decodeAABB
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble ) viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) ) strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
pure ( Document { displayName, mbFilePath, unsavedChanges, bounds, viewportCenter, zoomFactor, documentUnique, strokes } ) pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes } )

View file

@ -30,9 +30,9 @@ import Data.Act
) )
-- containers -- containers
import Data.IntMap.Strict import Data.Map.Strict
( IntMap ) ( Map )
import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map
( insert, lookup ) ( insert, lookup )
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
@ -68,12 +68,6 @@ import MetaBrush.Document.Selection
, dragMoveSelect, translateSelection , dragMoveSelect, translateSelection
, deleteSelected , deleteSelected
) )
import MetaBrush.Event.KeyCodes
( pattern Escape, pattern Return, pattern Delete
, pattern Control_L, pattern Control_R
, pattern Shift_L , pattern Shift_R
, pattern F1
)
import MetaBrush.UI.Coordinates import MetaBrush.UI.Coordinates
( toViewportCoordinates ) ( toViewportCoordinates )
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
@ -81,13 +75,13 @@ import MetaBrush.UI.InfoBar
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool(..), Mode ) ( Tool(..), Mode )
import MetaBrush.Unique import MetaBrush.Unique
( UniqueSupply ) ( UniqueSupply, Unique )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
handleEvents handleEvents
:: UniqueSupply :: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.Window -> GTK.DrawingArea -> InfoBar -> GTK.Window -> GTK.DrawingArea -> InfoBar
@ -143,7 +137,7 @@ data PartialPath
-- Mouse events. -- Mouse events.
handleMotionEvent handleMotionEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Tool
-> STM.TVar ( Maybe PartialPath ) -> STM.TVar ( Maybe PartialPath )
@ -162,7 +156,7 @@ handleMotionEvent
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do for_ ( Map.lookup i docs ) \ ( Document { .. } ) -> do
---------------------------------------------------------- ----------------------------------------------------------
-- Update mouse position in info bar on mouse move event. -- Update mouse position in info bar on mouse move event.
@ -195,7 +189,7 @@ handleMotionEvent
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
case tool of case tool of
Pen Pen
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys | any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys
, Just pp <- mbPartialPath , Just pp <- mbPartialPath
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } ) -> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
_ -> pure () _ -> pure ()
@ -204,7 +198,7 @@ handleMotionEvent
pure True pure True
handleScrollEvent handleScrollEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Tool
-> GTK.DrawingArea -> InfoBar -> GTK.DrawingArea -> InfoBar
@ -229,7 +223,7 @@ handleScrollEvent
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do for_ ( Map.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
pressedKeys <- STM.readTVarIO pressedKeysTVar pressedKeys <- STM.readTVarIO pressedKeysTVar
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
@ -240,7 +234,7 @@ handleScrollEvent
newDoc :: Document newDoc :: Document
newDoc newDoc
-- Zooming using 'Control'. -- Zooming using 'Control'.
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys | any ( \ key -> key == GDK.KEY_Control_L || key == GDK.KEY_Control_R ) pressedKeys
= let = let
newZoomFactor :: Double newZoomFactor :: Double
newZoomFactor newZoomFactor
@ -254,7 +248,7 @@ handleScrollEvent
oldCenter oldCenter
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter } in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
-- Vertical scrolling turned into horizontal scrolling using 'Shift'. -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
| dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys | dx == 0 && any ( \ key -> key == GDK.KEY_Shift_L || key == GDK.KEY_Shift_R ) pressedKeys
= let = let
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) oldCenter
@ -265,8 +259,8 @@ handleScrollEvent
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) oldCenter
in doc { viewportCenter = newCenter } in doc { viewportCenter = newCenter }
docs' :: IntMap Document docs' :: Map Unique Document
docs' = IntMap.insert i newDoc docs docs' = Map.insert i newDoc docs
finalZoomFactor :: Double finalZoomFactor :: Double
finalZoomFactor = zoomFactor newDoc finalZoomFactor = zoomFactor newDoc
finalCenter :: Point2D Double finalCenter :: Point2D Double
@ -292,7 +286,7 @@ handleScrollEvent
handleMouseButtonEvent handleMouseButtonEvent
:: UniqueSupply :: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
@ -315,7 +309,7 @@ handleMouseButtonEvent
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseClickEvent x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY mouseClickEvent y <- GDK.getEventButtonY mouseClickEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
@ -346,8 +340,8 @@ handleMouseButtonEvent
| Just newDoc <- dragMoveSelect mode pos doc | Just newDoc <- dragMoveSelect mode pos doc
-> do -> do
let let
newDocs :: IntMap Document newDocs :: Map Unique Document
newDocs = IntMap.insert i newDoc docs newDocs = Map.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs STM.writeTVar openDocumentsTVar newDocs
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos ) STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
-- Rectangular selection. -- Rectangular selection.
@ -370,8 +364,8 @@ handleMouseButtonEvent
} }
) )
let let
newDocs :: IntMap Document newDocs :: Map Unique Document
newDocs = IntMap.insert i newDoc docs newDocs = Map.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs STM.writeTVar openDocumentsTVar newDocs
-- Path already started: indicate that we are continuing a path. -- Path already started: indicate that we are continuing a path.
Just pp -> Just pp ->
@ -391,7 +385,7 @@ handleMouseButtonEvent
handleMouseButtonRelease handleMouseButtonRelease
:: UniqueSupply :: UniqueSupply
-> STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe HoldEvent ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
@ -414,7 +408,7 @@ handleMouseButtonRelease
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do for_ ( Map.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
x <- GDK.getEventButtonX mouseReleaseEvent x <- GDK.getEventButtonX mouseReleaseEvent
y <- GDK.getEventButtonY mouseReleaseEvent y <- GDK.getEventButtonY mouseReleaseEvent
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
@ -524,8 +518,8 @@ handleMouseButtonRelease
pure ( addToAnchor anchor newSegment doc ) pure ( addToAnchor anchor newSegment doc )
let let
newDocs :: IntMap Document newDocs :: Map Unique Document
newDocs = IntMap.insert i newDoc docs newDocs = Map.insert i newDoc docs
STM.writeTVar openDocumentsTVar newDocs STM.writeTVar openDocumentsTVar newDocs
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
@ -538,7 +532,7 @@ handleMouseButtonRelease
-- Keyboard events. -- Keyboard events.
handleKeyboardPressEvent handleKeyboardPressEvent
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) :: STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ] -> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar [ Word32 ]
-> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath ) -> STM.TVar Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
-> GTK.DrawingArea -> GTK.DrawingArea
@ -555,8 +549,8 @@ handleKeyboardPressEvent
pressedKeys <- STM.readTVar pressedKeysTVar pressedKeys <- STM.readTVar pressedKeysTVar
STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys ) STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
case keyCode of case keyCode of
Escape -> GTK.mainQuit GDK.KEY_Escape -> GTK.mainQuit
Return -> do GDK.KEY_Return -> do
tool <- STM.readTVarIO toolTVar tool <- STM.readTVarIO toolTVar
case tool of case tool of
-- End ongoing drawing on pressing enter key. -- End ongoing drawing on pressing enter key.
@ -564,7 +558,7 @@ handleKeyboardPressEvent
STM.atomically $ STM.writeTVar partialPathTVar Nothing STM.atomically $ STM.writeTVar partialPathTVar Nothing
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
_ -> pure () _ -> pure ()
Delete -> do GDK.KEY_Delete -> do
tool <- STM.readTVarIO toolTVar tool <- STM.readTVarIO toolTVar
mode <- STM.readTVarIO modeTVar mode <- STM.readTVarIO modeTVar
case tool of case tool of
@ -573,17 +567,17 @@ handleKeyboardPressEvent
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc -> do for_ ( Map.lookup i docs ) \ doc -> do
let let
newDoc :: Document newDoc :: Document
newDoc = deleteSelected mode doc newDoc = deleteSelected mode doc
newDocs :: IntMap Document newDocs :: Map Unique Document
newDocs = IntMap.insert i newDoc docs newDocs = Map.insert i newDoc docs
STM.atomically $ STM.writeTVar openDocumentsTVar newDocs STM.atomically $ STM.writeTVar openDocumentsTVar newDocs
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
_ -> pure () _ -> pure ()
ctrl ctrl
| ctrl == Control_L || ctrl == Control_R | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
-> do -> do
---------------------------------------------------------- ----------------------------------------------------------
-- With the pen tool, pressing control moves -- With the pen tool, pressing control moves
@ -599,11 +593,11 @@ handleKeyboardPressEvent
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } ) STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
_ -> pure () _ -> pure ()
F1 -> do GDK.KEY_F1 -> do
mbActiveDoc <- STM.readTVarIO activeDocumentTVar mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ doc -> do for_ ( Map.lookup i docs ) \ doc -> do
writeFile "log.txt" ( show doc <> "\n\n" ) writeFile "log.txt" ( show doc <> "\n\n" )
_ -> pure () _ -> pure ()
pure True pure True

View file

@ -1,75 +0,0 @@
{-# LANGUAGE PatternSynonyms #-}
module MetaBrush.Event.KeyCodes where
-- base
import Data.Word
( Word32 )
--------------------------------------------------------------------------------
-- GDK keycodes.
pattern Escape :: Word32
pattern Escape = 0xff1b
pattern Delete :: Word32
pattern Delete = 0xffff
pattern BackSpace :: Word32
pattern BackSpace = 0xff08
pattern Tab :: Word32
pattern Tab = 0xff09
pattern Return :: Word32
pattern Return = 0xff0d
pattern Pause :: Word32
pattern Pause = 0xff13
pattern Left :: Word32
pattern Left = 0xff51
pattern Up :: Word32
pattern Up = 0xff52
pattern Right :: Word32
pattern Right = 0xff53
pattern Down :: Word32
pattern Down = 0xff54
pattern PageUp :: Word32
pattern PageUp = 0xff55
pattern Next :: Word32
pattern Next = 0xff56
pattern PageDown :: Word32
pattern PageDown = 0xff56
pattern End :: Word32
pattern End = 0xff57
pattern Shift_L :: Word32
pattern Shift_L = 0xffe1
pattern Shift_R :: Word32
pattern Shift_R = 0xffe2
pattern Control_L :: Word32
pattern Control_L = 0xffe3
pattern Control_R :: Word32
pattern Control_R = 0xffe4
pattern Alt_L :: Word32
pattern Alt_L = 0xffe9
pattern Alt_R :: Word32
pattern Alt_R = 0xffea
pattern F1 :: Word32
pattern F1 = 0xffbe
pattern F2 :: Word32
pattern F2 = 0xffbf
pattern F3 :: Word32
pattern F3 = 0xffc0
pattern F4 :: Word32
pattern F4 = 0xffc1
pattern F5 :: Word32
pattern F5 = 0xffc2
pattern F6 :: Word32
pattern F6 = 0xffc3
pattern F7 :: Word32
pattern F7 = 0xffc4
pattern F8 :: Word32
pattern F8 = 0xffc5
pattern F9 :: Word32
pattern F9 = 0xffc6
pattern F10 :: Word32
pattern F10 = 0xffc7
pattern F11 :: Word32
pattern F11 = 0xffc8
pattern F12 :: Word32
pattern F12 = 0xffc9

View file

@ -77,10 +77,10 @@ import MetaBrush.Document.Selection
( translateSelection ) ( translateSelection )
import MetaBrush.Event import MetaBrush.Event
( HoldEvent(..), PartialPath(..) ) ( HoldEvent(..), PartialPath(..) )
import MetaBrush.Render.Util
( withRGBA )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Mode(..) ) ( Mode(..) )
import MetaBrush.Util
( withRGBA )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -1,9 +1,8 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.FileBar module MetaBrush.UI.FileBar
( createFileBar ) ( createFileBar )
@ -12,14 +11,16 @@ module MetaBrush.UI.FileBar
-- base -- base
import Control.Monad import Control.Monad
( void ) ( void )
import Data.Maybe
( listToMaybe )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
-- containers -- containers
import Data.IntMap.Strict import Data.Map.Strict
( IntMap ) ( Map )
import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map
( lookup, traverseWithKey ) ( lookup, insert )
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
@ -28,7 +29,7 @@ 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
( TVar, writeTVar, readTVarIO ) ( TVar, writeTVar, readTVarIO, modifyTVar' )
-- text -- text
import Data.Text import Data.Text
@ -38,68 +39,111 @@ import Data.Text
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) ( Point2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ) ( Document(..), emptyDocument )
import MetaBrush.Render.Util
( widgetAddClass, widgetAddClasses )
import MetaBrush.UI.Coordinates import MetaBrush.UI.Coordinates
( toViewportCoordinates ) ( toViewportCoordinates )
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar ) ( InfoBar, InfoData(..), updateInfoBar )
import MetaBrush.Unique
( UniqueSupply, Unique, freshUnique, uniqueText )
import MetaBrush.Util
( widgetAddClass, widgetAddClasses
, (>>?=), Exists(..)
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Add the file bar: tabs allowing selection of the active document. data TabLocation
-- = AfterCurrentTab
-- Updates the active document when buttons are clicked. | LastTab
createFileBar deriving stock Show
:: STM.TVar ( Maybe Int )
-> STM.TVar ( IntMap Document )
-> GTK.Window
-> GTK.Label
-> GTK.DrawingArea
-> InfoBar
-> GTK.ScrolledWindow
-> IO ( IntMap GTK.RadioButton )
createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea infoBar fileBar = do
widgetAddClass fileBar "fileBar"
fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0 newFileTab
GTK.containerAdd fileBar fileTabs :: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
widgetAddClasses fileTabs [ "fileBar", "plain", "text" ] -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> GTK.Box -> GTK.RadioButton -> InfoBar
-> Maybe Document
-> TabLocation
-> IO ()
newFileTab
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
mbDoc
newTabLoc
= do
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) newDoc <- case mbDoc of
-- Use the provided document (e.g. document read from a file).
Just doc -> do
pure doc
-- Create a new empty document.
Nothing -> do
newDocUniq <- STM.atomically $ freshUnique uniqueSupply
pure ( emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
-- TODO: currently using static list of documents.
-- Need to dynamically update this widget as the user opens/closes documents.
documents <- STM.readTVarIO openDocumentsTVar
fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName = currDisplayName } ) -> do
-- File tab elements. -- File tab elements.
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) currDisplayName pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName newDoc )
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
closeFileButton <- GTK.buttonNewWithLabel "x" closeFileButton <- GTK.buttonNewWithLabel "x"
-- Create box for file tab elements. -- Create box for file tab elements.
tab <- GTK.boxNew GTK.OrientationHorizontal 0 tab <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClasses tab [ "fileBarTab" ] widgetAddClasses tab [ "fileBarTab" ]
GTK.boxPackStart fileTabs tab False False 0 GTK.boxPackStart fileTabsBox tab False False 0
GTK.boxPackStart tab pgButton True True 0 GTK.boxPackStart tab pgButton True True 0
GTK.boxPackStart tab closeFileButton False False 0 GTK.boxPackStart tab closeFileButton False False 0
widgetAddClasses pgButton [ "fileBarTabButton" ] widgetAddClasses pgButton [ "fileBarTabButton" ]
widgetAddClasses closeFileButton [ "fileBarCloseButton" ] widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
-- Make both file tab elements activate styling on the whole tab GTK.widgetShowAll tab
-- (e.g. hovering over the close file button should highlight the whole tab).
-- 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 ()
-- 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
void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
flags <- GTK.widgetGetStateFlags tab
GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
pure False
void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
flags <- GTK.widgetGetStateFlags tab
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
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 )
GTK.widgetQueueDraw viewportArea
void $ GTK.onButtonClicked pgButton do void $ GTK.onButtonClicked pgButton do
isActive <- GTK.toggleButtonGetActive pgButton isActive <- GTK.toggleButtonGetActive pgButton
flags <- GTK.widgetGetStateFlags tab flags <- GTK.widgetGetStateFlags tab
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 i ) ) STM.atomically ( STM.writeTVar activeDocumentTVar ( Just newUnique ) )
GTK.widgetQueueDraw viewportArea mbActiveDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
mbActiveDoc <- IntMap.lookup i <$> STM.readTVarIO openDocumentsTVar
case mbActiveDoc of case mbActiveDoc of
Nothing -> do Nothing -> do
GTK.labelSetText title "MetaBrush" GTK.labelSetText title "MetaBrush"
@ -128,35 +172,62 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea inf
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight ) , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
} }
updateInfoBar infoBar infoData updateInfoBar infoBar infoData
GTK.widgetQueueDraw viewportArea
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"
GTK.setWindowTitle window "MetaBrush" GTK.setWindowTitle window "MetaBrush"
{- --void $ GTK.onButtonClicked closeFileButton ... ... ...
void $ GTK.onButtonClicked closeFileButton do
closeFileDialog ...
-}
for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do GTK.toggleButtonSetActive pgButton True
void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
flags <- GTK.widgetGetStateFlags tab
GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
pure False
void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
flags <- GTK.widgetGetStateFlags tab
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
pure False
pure pgButton -- | Add the file bar: tabs allowing selection of the active document.
--
-- Updates the active document when buttons are clicked.
createFileBar
:: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
-> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
-> IO GTK.Box
createFileBar
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea infoBar
= do
GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever -- Create file bar: box containing scrollable tabs, and a "+" button after it.
GTK.scrolledWindowSetOverlayScrolling fileBar True fileBar <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClass fileBar "fileBar"
pure fileButtons fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True
--------------------------------------------------------- newFileButton <- GTK.buttonNewWithLabel "+"
-- Util. widgetAddClasses newFileButton [ "newFileButton" ]
data Exists c where GTK.boxPackStart fileBar fileTabsScroll True True 0
Exists :: c a => a -> Exists c GTK.boxPackStart fileBar newFileButton False False 0
fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0
GTK.containerAdd fileTabsScroll fileTabsBox
widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ]
-- Phantom radio button for when no page is selected (e.g. no documents opened yet).
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
documents <- STM.readTVarIO openDocumentsTVar
for_ documents \ doc ->
newFileTab
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
( Just doc )
LastTab
void $ GTK.onButtonClicked newFileButton do
newFileTab
uniqueSupply activeDocumentTVar openDocumentsTVar
window title viewportArea fileTabsBox fileBarPhantomRadioButton infoBar
Nothing
LastTab
pure fileBar

View file

@ -44,7 +44,7 @@ import MetaBrush.Asset.Cursor
( drawCursorIcon ) ( drawCursorIcon )
import MetaBrush.Asset.InfoBar import MetaBrush.Asset.InfoBar
( drawMagnifier, drawTopLeftCornerRect ) ( drawMagnifier, drawTopLeftCornerRect )
import MetaBrush.Render.Util import MetaBrush.Util
( widgetAddClass, widgetAddClasses ) ( widgetAddClass, widgetAddClasses )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -60,7 +60,7 @@ import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Asset.WindowIcons import MetaBrush.Asset.WindowIcons
( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
import MetaBrush.Render.Util import MetaBrush.Util
( widgetAddClass, widgetAddClasses ) ( widgetAddClass, widgetAddClasses )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -15,7 +15,7 @@ import Data.Foldable
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- MetaBrush -- MetaBrush
import MetaBrush.Render.Util import MetaBrush.Util
( widgetAddClass, widgetAddClasses ) ( widgetAddClass, widgetAddClasses )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -36,7 +36,7 @@ import MetaBrush.Asset.Cursor
( drawCursorIcon ) ( drawCursorIcon )
import MetaBrush.Asset.Tools import MetaBrush.Asset.Tools
( drawBrush, drawMeta, drawPath, drawPen ) ( drawBrush, drawMeta, drawPath, drawPen )
import MetaBrush.Render.Util import MetaBrush.Util
( widgetAddClass ) ( widgetAddClass )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -13,7 +13,7 @@ import qualified GI.Gdk as GDK
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- MetaBrush -- MetaBrush
import MetaBrush.Render.Util import MetaBrush.Util
( widgetAddClass ) ( widgetAddClass )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -1,4 +1,5 @@
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -7,14 +8,33 @@ module MetaBrush.Unique
( Unique, unsafeUnique ( Unique, unsafeUnique
, freshUnique, uniqueText , freshUnique, uniqueText
, UniqueSupply, newUniqueSupply , UniqueSupply, newUniqueSupply
, uniqueMapFromList
) )
where where
-- base -- base
import Control.Arrow
( (&&&) )
import Data.Int import Data.Int
( Int64 ) ( Int64 )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
import Foreign.Storable
( Storable )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( fromList )
-- generic-lens
import Data.Generics.Product.Typed
( HasType(typed) )
-- lens
import Control.Lens
( view )
-- stm -- stm
import Control.Concurrent.STM import Control.Concurrent.STM
@ -32,7 +52,7 @@ import qualified Data.Text as Text
newtype Unique = Unique { unique :: Int64 } newtype Unique = Unique { unique :: Int64 }
deriving stock Show deriving stock Show
deriving newtype ( Eq, Ord ) deriving newtype ( Eq, Ord, Storable )
unsafeUnique :: Word32 -> Unique unsafeUnique :: Word32 -> Unique
unsafeUnique i = Unique ( - fromIntegral i - 1 ) unsafeUnique i = Unique ( - fromIntegral i - 1 )
@ -54,3 +74,6 @@ freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
newUniqueSupply :: IO UniqueSupply newUniqueSupply :: IO UniqueSupply
newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 ) newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )
uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a
uniqueMapFromList = Map.fromList . map ( view typed &&& id )

View file

@ -1,13 +1,23 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Render.Util module MetaBrush.Util
( withRGBA, showRGBA ( withRGBA, showRGBA
, widgetAddClasses, widgetAddClass , widgetAddClasses, widgetAddClass
, (>=?=>), (>>?=)
, Exists(..)
) )
where where
-- base -- base
import Control.Monad
( (>=>) )
import Data.Coerce
( coerce )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import GHC.Stack import GHC.Stack
@ -26,6 +36,8 @@ import Data.Text
-- transformers -- transformers
import Control.Monad.IO.Class import Control.Monad.IO.Class
( MonadIO ) ( MonadIO )
import Control.Monad.Trans.Maybe
( MaybeT(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -48,3 +60,18 @@ widgetAddClasses widget classNames = do
widgetAddClass :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> Text -> m () widgetAddClass :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> Text -> m ()
widgetAddClass widget className = GTK.widgetGetStyleContext widget >>= ( `GTK.styleContextAddClass` className ) widgetAddClass widget className = GTK.widgetGetStyleContext widget >>= ( `GTK.styleContextAddClass` className )
--------------------------------------------------------------------------------
infixr 1 >=?=>
(>=?=>) :: forall m a b c. Monad m => ( a -> m ( Maybe b ) ) -> ( b -> m ( Maybe c ) ) -> ( a -> m ( Maybe c ) )
(>=?=>) = coerce ( (>=>) @( MaybeT m ) @a @b @c )
infixl 1 >>?=
(>>?=) :: forall m a b. Monad m => m ( Maybe a ) -> ( a -> m ( Maybe b ) ) -> m ( Maybe b )
(>>?=) = coerce ( (>>=) @( MaybeT m ) @a @b )
--------------------------------------------------------------------------------
data Exists c where
Exists :: c a => a -> Exists c