mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
update file tabs dynamically
This commit is contained in:
parent
8a6b4f5391
commit
101d9515c0
|
@ -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:
|
||||||
|
|
141
app/Main.hs
141
app/Main.hs
|
@ -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
|
||||||
|
|
|
@ -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;
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 = []
|
||||||
|
}
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 } )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
( 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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
Loading…
Reference in a new issue