mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
update file tabs dynamically
This commit is contained in:
sheaf
parent
8a6b4f5391
commit
101d9515c0
|
|
@ -109,9 +109,7 @@ executable MetaBrush
|
|||
, MetaBrush.Document.Selection
|
||||
, MetaBrush.Document.Serialise
|
||||
, MetaBrush.Event
|
||||
, MetaBrush.Event.KeyCodes
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Util
|
||||
, MetaBrush.Time
|
||||
, MetaBrush.UI.Coordinates
|
||||
, MetaBrush.UI.FileBar
|
||||
|
|
@ -121,6 +119,7 @@ executable MetaBrush
|
|||
, MetaBrush.UI.ToolBar
|
||||
, MetaBrush.UI.Viewport
|
||||
, MetaBrush.Unique
|
||||
, MetaBrush.Util
|
||||
, Paths_MetaBrush
|
||||
|
||||
autogen-modules:
|
||||
|
|
|
|||
141
app/Main.hs
141
app/Main.hs
|
|
@ -22,10 +22,8 @@ import System.Exit
|
|||
( exitSuccess )
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
( fromList )
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
|
|
@ -65,7 +63,7 @@ import MetaBrush.Asset.Colours
|
|||
import MetaBrush.Asset.Logo
|
||||
( drawLogo )
|
||||
import MetaBrush.Document
|
||||
( Document(..), AABB(..), Stroke(..)
|
||||
( Document(..), Stroke(..)
|
||||
, FocusState(..)
|
||||
, PointData(..), BrushPointData(..)
|
||||
, currentDocument
|
||||
|
|
@ -76,8 +74,6 @@ import MetaBrush.Event
|
|||
)
|
||||
import MetaBrush.Render.Document
|
||||
( renderDocument )
|
||||
import MetaBrush.Render.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.UI.FileBar
|
||||
( createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
|
|
@ -91,64 +87,65 @@ import MetaBrush.UI.ToolBar
|
|||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), createViewport )
|
||||
import MetaBrush.Unique
|
||||
( newUniqueSupply, unsafeUnique )
|
||||
( newUniqueSupply
|
||||
, Unique, unsafeUnique
|
||||
, uniqueMapFromList
|
||||
)
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
( getDataFileName )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
testDocuments :: IntMap Document
|
||||
testDocuments = IntMap.fromList
|
||||
$ zip [0..]
|
||||
[ Document
|
||||
{ displayName = "Closed"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
|
||||
, viewportCenter = Point2D 50 50
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 0
|
||||
, strokes = [ Stroke
|
||||
{ strokeName = "Ellipse"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 10
|
||||
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
|
||||
}
|
||||
]
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Line"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = True
|
||||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
|
||||
, viewportCenter = Point2D 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 1
|
||||
, strokes = [ Stroke
|
||||
{ strokeName = "Line"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 11
|
||||
, strokePoints = linePts
|
||||
}
|
||||
]
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Short line"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
|
||||
, viewportCenter = Point2D 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 2
|
||||
, strokes = [ Stroke
|
||||
{ strokeName = "ShortLine"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 12
|
||||
, strokePoints = linePts2
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
testDocuments :: Map Unique Document
|
||||
testDocuments = uniqueMapFromList
|
||||
[ Document
|
||||
{ displayName = "Closed"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, viewportCenter = Point2D 50 50
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 0
|
||||
, strokes = [ Stroke
|
||||
{ strokeName = "Ellipse"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 10
|
||||
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
|
||||
}
|
||||
]
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Line"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = True
|
||||
, viewportCenter = Point2D 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 1
|
||||
, strokes = [ Stroke
|
||||
{ strokeName = "Line"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 11
|
||||
, strokePoints = linePts
|
||||
}
|
||||
]
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Short line"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, viewportCenter = Point2D 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 2
|
||||
, strokes = [ Stroke
|
||||
{ strokeName = "ShortLine"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 12
|
||||
, strokePoints = linePts2
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
where
|
||||
linePts :: Seq ( StrokePoint PointData )
|
||||
linePts = Seq.fromList
|
||||
|
|
@ -176,8 +173,8 @@ main = do
|
|||
-- Initialise state
|
||||
|
||||
uniqueSupply <- newUniqueSupply
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing
|
||||
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
||||
|
|
@ -248,14 +245,9 @@ main = do
|
|||
GTK.panedPack1 mainPane mainView True False
|
||||
GTK.panedPack2 mainPane panelBox False False
|
||||
|
||||
fileBar <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
|
||||
viewportGrid <- GTK.gridNew
|
||||
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
|
||||
|
||||
|
|
@ -327,15 +319,14 @@ main = do
|
|||
---------------------------------------------------------
|
||||
-- File bar
|
||||
|
||||
_ <-
|
||||
fileBar <-
|
||||
createFileBar
|
||||
activeDocumentTVar
|
||||
openDocumentsTVar
|
||||
window
|
||||
title
|
||||
viewportDrawingArea
|
||||
infoBarElements
|
||||
fileBar
|
||||
uniqueSupply activeDocumentTVar openDocumentsTVar
|
||||
window title viewportDrawingArea infoBarElements
|
||||
|
||||
GTK.boxPackStart mainView fileBar False False 0
|
||||
GTK.boxPackStart mainView viewportGrid True True 0
|
||||
GTK.boxPackStart mainView infoBar False False 0
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels
|
||||
|
|
|
|||
|
|
@ -320,7 +320,7 @@ tooltip {
|
|||
}
|
||||
|
||||
.fileBarCloseButton {
|
||||
padding-left: 5px;
|
||||
padding-left: 1px;
|
||||
padding-right: 5px;
|
||||
margin: 0px;
|
||||
color: rgba(212, 190, 152,0.2);
|
||||
|
|
@ -330,6 +330,25 @@ tooltip {
|
|||
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 {
|
||||
min-width: 120px;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), Colours )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
|
||||
module MetaBrush.Document
|
||||
( AABB(..)
|
||||
, Document(..), currentDocument
|
||||
, Document(..), emptyDocument, currentDocument
|
||||
, Stroke(..)
|
||||
, PointData(..), BrushPointData(..)
|
||||
, FocusState(..)
|
||||
|
|
@ -16,15 +16,17 @@ module MetaBrush.Document
|
|||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( lookup )
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
|
|
@ -50,7 +52,7 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D )
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -66,7 +68,6 @@ data Document
|
|||
{ displayName :: !Text
|
||||
, mbFilePath :: !( Maybe FilePath )
|
||||
, unsavedChanges :: !Bool
|
||||
, bounds :: !AABB
|
||||
, viewportCenter :: !( Point2D Double )
|
||||
, zoomFactor :: !Double
|
||||
, documentUnique :: Unique
|
||||
|
|
@ -107,11 +108,23 @@ _selection = field' @"pointData" . typed @FocusState
|
|||
_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
|
||||
_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
|
||||
mbActive <- STM.readTVar activeDocumentTVar
|
||||
case mbActive of
|
||||
Nothing -> pure Nothing
|
||||
Just i -> do
|
||||
Just unique -> do
|
||||
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 = []
|
||||
}
|
||||
|
|
|
|||
|
|
@ -42,6 +42,9 @@ import Data.Generics.Product.Fields
|
|||
import Data.Generics.Product.Typed
|
||||
( HasType )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk.Constants as GDK
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view, set, over, mapped )
|
||||
|
|
@ -69,10 +72,6 @@ import MetaBrush.Document
|
|||
( Document(..), Stroke(..)
|
||||
, FocusState(..), _selection
|
||||
)
|
||||
import MetaBrush.Event.KeyCodes
|
||||
( pattern Alt_L , pattern Alt_R
|
||||
, pattern Shift_L, pattern Shift_R
|
||||
)
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Mode(..) )
|
||||
|
||||
|
|
@ -96,11 +95,11 @@ instance Monoid SelectionMode where
|
|||
|
||||
selectionMode :: [ Word32 ] -> SelectionMode
|
||||
selectionMode = foldMap \case
|
||||
Alt_L -> Subtract
|
||||
Alt_R -> Subtract
|
||||
Shift_L -> Add
|
||||
Shift_R -> Add
|
||||
_ -> New
|
||||
GDK.KEY_Alt_L -> Subtract
|
||||
GDK.KEY_Alt_R -> Subtract
|
||||
GDK.KEY_Shift_L -> Add
|
||||
GDK.KEY_Shift_R -> Add
|
||||
_ -> New
|
||||
|
||||
-- | Updates the selected objects on a single click selection event.
|
||||
selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document
|
||||
|
|
|
|||
|
|
@ -15,12 +15,18 @@ import Data.Foldable
|
|||
( toList )
|
||||
import Data.Functor.Contravariant
|
||||
( contramap )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce ) -- Tony Morris special
|
||||
|
||||
-- bytestring
|
||||
import qualified Data.ByteString as Strict
|
||||
( ByteString )
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
( ByteString )
|
||||
import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
|
||||
( toLazyByteString )
|
||||
|
||||
-- containers
|
||||
import Data.Sequence
|
||||
|
|
@ -58,18 +64,29 @@ import qualified Waargonaut.Decode as JSON.Decoder
|
|||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder, Encoder' )
|
||||
import qualified Waargonaut.Encode as JSON.Encoder
|
||||
( simplePureEncodeByteString
|
||||
( runEncoder
|
||||
, 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
|
||||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) ) --, Vector2D(..), Mat22(..) )
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
, AABB(..)
|
||||
, Stroke(..)
|
||||
, PointData(..)
|
||||
, 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 = 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 mfp
|
||||
= fmap ( Bifunctor.first fst )
|
||||
|
|
@ -130,7 +159,7 @@ decodeMat22 dec =
|
|||
<*> JSON.Decoder.atKey "m01" dec
|
||||
<*> JSON.Decoder.atKey "m10" dec
|
||||
<*> JSON.Decoder.atKey "m11" dec
|
||||
-}
|
||||
|
||||
|
||||
|
||||
encodeAABB :: Applicative f => JSON.Encoder f AABB
|
||||
|
|
@ -149,7 +178,7 @@ decodeAABB = do
|
|||
where
|
||||
dec :: JSON.Decoder m ( Point2D Double )
|
||||
dec = decodePoint2D decodeDouble
|
||||
|
||||
-}
|
||||
|
||||
|
||||
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 = 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' "bounds" encodeAABB bounds
|
||||
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
|
||||
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
|
||||
|
|
@ -255,9 +283,8 @@ decodeDocument uniqueSupply mbFilePath = do
|
|||
let
|
||||
unsavedChanges :: Bool
|
||||
unsavedChanges = False
|
||||
bounds <- JSON.Decoder.atKey "bounds" decodeAABB
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
|
||||
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique 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 } )
|
||||
|
|
|
|||
|
|
@ -30,9 +30,9 @@ import Data.Act
|
|||
)
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( insert, lookup )
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
|
|
@ -68,12 +68,6 @@ import MetaBrush.Document.Selection
|
|||
, dragMoveSelect, translateSelection
|
||||
, 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
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
|
|
@ -81,13 +75,13 @@ import MetaBrush.UI.InfoBar
|
|||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply )
|
||||
( UniqueSupply, Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
handleEvents
|
||||
:: 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 Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
|
||||
-> GTK.Window -> GTK.DrawingArea -> InfoBar
|
||||
|
|
@ -143,7 +137,7 @@ data PartialPath
|
|||
-- Mouse events.
|
||||
|
||||
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 Tool
|
||||
-> STM.TVar ( Maybe PartialPath )
|
||||
|
|
@ -162,7 +156,7 @@ handleMotionEvent
|
|||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
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.
|
||||
|
|
@ -195,7 +189,7 @@ handleMotionEvent
|
|||
mbPartialPath <- STM.readTVar partialPathTVar
|
||||
case tool of
|
||||
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
|
||||
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
||||
_ -> pure ()
|
||||
|
|
@ -204,7 +198,7 @@ handleMotionEvent
|
|||
pure True
|
||||
|
||||
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 Tool
|
||||
-> GTK.DrawingArea -> InfoBar
|
||||
|
|
@ -229,7 +223,7 @@ handleScrollEvent
|
|||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
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
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
|
|
@ -240,7 +234,7 @@ handleScrollEvent
|
|||
newDoc :: Document
|
||||
newDoc
|
||||
-- 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
|
||||
newZoomFactor :: Double
|
||||
newZoomFactor
|
||||
|
|
@ -254,7 +248,7 @@ handleScrollEvent
|
|||
• oldCenter
|
||||
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
|
||||
-- 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
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
|
||||
|
|
@ -265,8 +259,8 @@ handleScrollEvent
|
|||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
docs' :: IntMap Document
|
||||
docs' = IntMap.insert i newDoc docs
|
||||
docs' :: Map Unique Document
|
||||
docs' = Map.insert i newDoc docs
|
||||
finalZoomFactor :: Double
|
||||
finalZoomFactor = zoomFactor newDoc
|
||||
finalCenter :: Point2D Double
|
||||
|
|
@ -292,7 +286,7 @@ handleScrollEvent
|
|||
|
||||
handleMouseButtonEvent
|
||||
:: 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 Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
|
||||
-> GTK.DrawingArea
|
||||
|
|
@ -315,7 +309,7 @@ handleMouseButtonEvent
|
|||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
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
|
||||
y <- GDK.getEventButtonY mouseClickEvent
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
|
|
@ -346,8 +340,8 @@ handleMouseButtonEvent
|
|||
| Just newDoc <- dragMoveSelect mode pos doc
|
||||
-> do
|
||||
let
|
||||
newDocs :: IntMap Document
|
||||
newDocs = IntMap.insert i newDoc docs
|
||||
newDocs :: Map Unique Document
|
||||
newDocs = Map.insert i newDoc docs
|
||||
STM.writeTVar openDocumentsTVar newDocs
|
||||
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
|
||||
-- Rectangular selection.
|
||||
|
|
@ -370,8 +364,8 @@ handleMouseButtonEvent
|
|||
}
|
||||
)
|
||||
let
|
||||
newDocs :: IntMap Document
|
||||
newDocs = IntMap.insert i newDoc docs
|
||||
newDocs :: Map Unique Document
|
||||
newDocs = Map.insert i newDoc docs
|
||||
STM.writeTVar openDocumentsTVar newDocs
|
||||
-- Path already started: indicate that we are continuing a path.
|
||||
Just pp ->
|
||||
|
|
@ -391,7 +385,7 @@ handleMouseButtonEvent
|
|||
|
||||
handleMouseButtonRelease
|
||||
:: 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 Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
|
||||
-> GTK.DrawingArea
|
||||
|
|
@ -414,7 +408,7 @@ handleMouseButtonRelease
|
|||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
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
|
||||
y <- GDK.getEventButtonY mouseReleaseEvent
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
|
|
@ -524,8 +518,8 @@ handleMouseButtonRelease
|
|||
pure ( addToAnchor anchor newSegment doc )
|
||||
|
||||
let
|
||||
newDocs :: IntMap Document
|
||||
newDocs = IntMap.insert i newDoc docs
|
||||
newDocs :: Map Unique Document
|
||||
newDocs = Map.insert i newDoc docs
|
||||
STM.writeTVar openDocumentsTVar newDocs
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
|
|
@ -538,7 +532,7 @@ handleMouseButtonRelease
|
|||
-- Keyboard events.
|
||||
|
||||
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 Tool -> STM.TVar Mode -> STM.TVar ( Maybe PartialPath )
|
||||
-> GTK.DrawingArea
|
||||
|
|
@ -555,8 +549,8 @@ handleKeyboardPressEvent
|
|||
pressedKeys <- STM.readTVar pressedKeysTVar
|
||||
STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
|
||||
case keyCode of
|
||||
Escape -> GTK.mainQuit
|
||||
Return -> do
|
||||
GDK.KEY_Escape -> GTK.mainQuit
|
||||
GDK.KEY_Return -> do
|
||||
tool <- STM.readTVarIO toolTVar
|
||||
case tool of
|
||||
-- End ongoing drawing on pressing enter key.
|
||||
|
|
@ -564,7 +558,7 @@ handleKeyboardPressEvent
|
|||
STM.atomically $ STM.writeTVar partialPathTVar Nothing
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
_ -> pure ()
|
||||
Delete -> do
|
||||
GDK.KEY_Delete -> do
|
||||
tool <- STM.readTVarIO toolTVar
|
||||
mode <- STM.readTVarIO modeTVar
|
||||
case tool of
|
||||
|
|
@ -573,17 +567,17 @@ handleKeyboardPressEvent
|
|||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ doc -> do
|
||||
for_ ( Map.lookup i docs ) \ doc -> do
|
||||
let
|
||||
newDoc :: Document
|
||||
newDoc = deleteSelected mode doc
|
||||
newDocs :: IntMap Document
|
||||
newDocs = IntMap.insert i newDoc docs
|
||||
newDocs :: Map Unique Document
|
||||
newDocs = Map.insert i newDoc docs
|
||||
STM.atomically $ STM.writeTVar openDocumentsTVar newDocs
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
_ -> pure ()
|
||||
ctrl
|
||||
| ctrl == Control_L || ctrl == Control_R
|
||||
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
|
||||
-> do
|
||||
----------------------------------------------------------
|
||||
-- With the pen tool, pressing control moves
|
||||
|
|
@ -599,11 +593,11 @@ handleKeyboardPressEvent
|
|||
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
_ -> pure ()
|
||||
F1 -> do
|
||||
GDK.KEY_F1 -> do
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
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" )
|
||||
_ -> pure ()
|
||||
pure True
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -77,10 +77,10 @@ import MetaBrush.Document.Selection
|
|||
( translateSelection )
|
||||
import MetaBrush.Event
|
||||
( HoldEvent(..), PartialPath(..) )
|
||||
import MetaBrush.Render.Util
|
||||
( withRGBA )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Mode(..) )
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.FileBar
|
||||
( createFileBar )
|
||||
|
|
@ -12,14 +11,16 @@ module MetaBrush.UI.FileBar
|
|||
-- base
|
||||
import Control.Monad
|
||||
( void )
|
||||
import Data.Maybe
|
||||
( listToMaybe )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
( lookup, traverseWithKey )
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( lookup, insert )
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
|
@ -28,7 +29,7 @@ import qualified GI.Gtk as GTK
|
|||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar, writeTVar, readTVarIO )
|
||||
( TVar, writeTVar, readTVarIO, modifyTVar' )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
|
|
@ -38,68 +39,111 @@ import Data.Text
|
|||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..) )
|
||||
import MetaBrush.Render.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
( Document(..), emptyDocument )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( 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.
|
||||
--
|
||||
-- Updates the active document when buttons are clicked.
|
||||
createFileBar
|
||||
:: 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"
|
||||
data TabLocation
|
||||
= AfterCurrentTab
|
||||
| LastTab
|
||||
deriving stock Show
|
||||
|
||||
fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
GTK.containerAdd fileBar fileTabs
|
||||
widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
|
||||
newFileTab
|
||||
:: UniqueSupply -> STM.TVar ( Maybe Unique ) -> STM.TVar ( Map Unique Document )
|
||||
-> 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.
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) currDisplayName
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName newDoc )
|
||||
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
|
||||
closeFileButton <- GTK.buttonNewWithLabel "x"
|
||||
|
||||
-- Create box for file tab elements.
|
||||
tab <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClasses tab [ "fileBarTab" ]
|
||||
GTK.boxPackStart fileTabs tab False False 0
|
||||
GTK.boxPackStart tab pgButton True True 0
|
||||
GTK.boxPackStart tab closeFileButton False False 0
|
||||
|
||||
GTK.boxPackStart fileTabsBox tab False False 0
|
||||
GTK.boxPackStart tab pgButton True True 0
|
||||
GTK.boxPackStart tab closeFileButton False False 0
|
||||
widgetAddClasses pgButton [ "fileBarTabButton" ]
|
||||
widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
|
||||
|
||||
-- Make both file tab elements activate styling on the whole tab
|
||||
-- (e.g. hovering over the close file button should highlight the whole tab).
|
||||
GTK.widgetShowAll 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
|
||||
isActive <- GTK.toggleButtonGetActive pgButton
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
if isActive
|
||||
then do
|
||||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
|
||||
STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) )
|
||||
GTK.widgetQueueDraw viewportArea
|
||||
mbActiveDoc <- IntMap.lookup i <$> STM.readTVarIO openDocumentsTVar
|
||||
STM.atomically ( STM.writeTVar activeDocumentTVar ( Just newUnique ) )
|
||||
mbActiveDoc <- Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
|
||||
case mbActiveDoc of
|
||||
Nothing -> do
|
||||
GTK.labelSetText title "MetaBrush"
|
||||
|
|
@ -128,35 +172,62 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea inf
|
|||
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
GTK.widgetQueueDraw viewportArea
|
||||
else do
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||
GTK.labelSetText title "MetaBrush"
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
|
||||
{-
|
||||
void $ GTK.onButtonClicked closeFileButton do
|
||||
closeFileDialog ...
|
||||
-}
|
||||
--void $ GTK.onButtonClicked closeFileButton ... ... ...
|
||||
|
||||
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
|
||||
GTK.toggleButtonSetActive pgButton True
|
||||
|
||||
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
|
||||
GTK.scrolledWindowSetOverlayScrolling fileBar True
|
||||
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
||||
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
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Util.
|
||||
newFileButton <- GTK.buttonNewWithLabel "+"
|
||||
widgetAddClasses newFileButton [ "newFileButton" ]
|
||||
|
||||
data Exists c where
|
||||
Exists :: c a => a -> Exists c
|
||||
GTK.boxPackStart fileBar fileTabsScroll True True 0
|
||||
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
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ import MetaBrush.Asset.Cursor
|
|||
( drawCursorIcon )
|
||||
import MetaBrush.Asset.InfoBar
|
||||
( drawMagnifier, drawTopLeftCornerRect )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ import MetaBrush.Asset.Colours
|
|||
( Colours )
|
||||
import MetaBrush.Asset.WindowIcons
|
||||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import Data.Foldable
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ import MetaBrush.Asset.Cursor
|
|||
( drawCursorIcon )
|
||||
import MetaBrush.Asset.Tools
|
||||
( drawBrush, drawMeta, drawPath, drawPen )
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import qualified GI.Gdk as GDK
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Render.Util
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -7,14 +8,33 @@ module MetaBrush.Unique
|
|||
( Unique, unsafeUnique
|
||||
, freshUnique, uniqueText
|
||||
, UniqueSupply, newUniqueSupply
|
||||
, uniqueMapFromList
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (&&&) )
|
||||
import Data.Int
|
||||
( Int64 )
|
||||
import Data.Word
|
||||
( 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
|
||||
import Control.Concurrent.STM
|
||||
|
|
@ -32,7 +52,7 @@ import qualified Data.Text as Text
|
|||
|
||||
newtype Unique = Unique { unique :: Int64 }
|
||||
deriving stock Show
|
||||
deriving newtype ( Eq, Ord )
|
||||
deriving newtype ( Eq, Ord, Storable )
|
||||
|
||||
unsafeUnique :: Word32 -> Unique
|
||||
unsafeUnique i = Unique ( - fromIntegral i - 1 )
|
||||
|
|
@ -54,3 +74,6 @@ freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
|
|||
|
||||
newUniqueSupply :: IO UniqueSupply
|
||||
newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )
|
||||
|
||||
uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a
|
||||
uniqueMapFromList = Map.fromList . map ( view typed &&& id )
|
||||
|
|
|
|||
|
|
@ -1,13 +1,23 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Render.Util
|
||||
module MetaBrush.Util
|
||||
( withRGBA, showRGBA
|
||||
, widgetAddClasses, widgetAddClass
|
||||
, (>=?=>), (>>?=)
|
||||
, Exists(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( (>=>) )
|
||||
import Data.Coerce
|
||||
( coerce )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import GHC.Stack
|
||||
|
|
@ -26,6 +36,8 @@ import Data.Text
|
|||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( 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 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
|
||||
Loading…
Reference in a new issue