mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
Switch to GTK4
This commit is contained in:
sheaf
parent
a9adcba8eb
commit
1b0382f3b0
|
|
@ -10,7 +10,7 @@ data-dir:
|
|||
assets
|
||||
data-files:
|
||||
theme.css
|
||||
icon.png
|
||||
icons/*
|
||||
description:
|
||||
|
||||
MetaBrush is a GUI for brush calligraphy based on Bézier curves.
|
||||
|
|
@ -118,6 +118,7 @@ executable MetaBrush
|
|||
|
||||
other-modules:
|
||||
MetaBrush.Action
|
||||
, MetaBrush.Application
|
||||
, MetaBrush.Asset.Brushes
|
||||
, MetaBrush.Asset.CloseTabButton
|
||||
, MetaBrush.Asset.Colours
|
||||
|
|
@ -175,7 +176,7 @@ executable MetaBrush
|
|||
, atomic-file-ops
|
||||
^>= 0.3.0.0
|
||||
, bytestring
|
||||
^>= 0.10.10.0
|
||||
>= 0.10.10.0 && < 0.12
|
||||
, directory
|
||||
>= 1.3.4.0 && < 1.4
|
||||
, dlist
|
||||
|
|
@ -191,7 +192,7 @@ executable MetaBrush
|
|||
, gi-cairo-connector
|
||||
^>= 0.1.0
|
||||
, gi-gdk
|
||||
>= 3.0.22 && < 3.1
|
||||
>= 4.0.2 && < 4.1
|
||||
, gi-gio
|
||||
>= 2.0.27 && < 2.1
|
||||
, gi-glib
|
||||
|
|
@ -199,9 +200,9 @@ executable MetaBrush
|
|||
, gi-gobject
|
||||
^>= 2.0.24
|
||||
, gi-gtk
|
||||
>= 3.0.35 && < 3.1
|
||||
, gi-gtksource
|
||||
>= 3.0.23 && < 3.1
|
||||
>= 4.0.3 && < 4.1
|
||||
--, gi-gtksource
|
||||
-- >= 3.0.23 && < 3.1
|
||||
, hashable
|
||||
^>= 1.3.0.0
|
||||
, haskell-gi
|
||||
|
|
|
|||
466
app/Main.hs
466
app/Main.hs
|
|
@ -1,15 +1,5 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NegativeLiterals #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Main
|
||||
( main )
|
||||
|
|
@ -17,149 +7,24 @@ module Main
|
|||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( forever, void )
|
||||
import Control.Monad.ST
|
||||
( stToIO )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Function
|
||||
( (&) )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
( void )
|
||||
import System.Exit
|
||||
( exitSuccess )
|
||||
( ExitCode(..), exitSuccess, exitWith )
|
||||
import GHC.Conc
|
||||
( forkIO, getNumProcessors, setNumCapabilities )
|
||||
( getNumProcessors, setNumCapabilities )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
( empty )
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
-- directory
|
||||
import qualified System.Directory as Directory
|
||||
( canonicalizePath )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- gi-cairo-render
|
||||
import qualified GI.Cairo.Render as Cairo
|
||||
( Render )
|
||||
|
||||
-- gi-cairo-connector
|
||||
import qualified GI.Cairo.Render.Connector as Cairo
|
||||
( renderWithContext )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- gi-glib
|
||||
import qualified GI.GLib.Constants as GLib
|
||||
-- gi-gobject
|
||||
import qualified GI.GObject as GObject
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( (.~) )
|
||||
import Control.Lens.At
|
||||
( at )
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically, retry )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( newTVarIO, readTVar, writeTVar )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( (:=)(..), (&), rnil )
|
||||
|
||||
-- text
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
|
||||
-- unordered-containers
|
||||
import Data.HashMap.Strict
|
||||
( HashMap )
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
( fromList )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Cubic.Fit
|
||||
( FitParameters(..) )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
|
||||
import Math.Bezier.Stroke
|
||||
( invalidateCache )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Action
|
||||
( ActionOrigin(..) )
|
||||
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
|
||||
( circle )
|
||||
import MetaBrush.Asset.Colours
|
||||
( getColours )
|
||||
import MetaBrush.Asset.Logo
|
||||
( drawLogo )
|
||||
import MetaBrush.Brush
|
||||
( Brush, newBrushReference )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..)
|
||||
, HoldAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( emptyDocument
|
||||
, Stroke(..), FocusState(..)
|
||||
, PointData(..)
|
||||
)
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), newHistory )
|
||||
import MetaBrush.Document.Update
|
||||
( activeDocument, withActiveDocument )
|
||||
import MetaBrush.Event
|
||||
( handleEvents )
|
||||
import MetaBrush.Render.Document
|
||||
( blankRender, getDocumentRender )
|
||||
import MetaBrush.Render.Rulers
|
||||
( renderRuler )
|
||||
import MetaBrush.UI.FileBar
|
||||
( FileBar(..), createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar(..), createInfoBar, updateInfoBar )
|
||||
import MetaBrush.UI.Menu
|
||||
( createMenuBar )
|
||||
import MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..), createToolBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..), createViewport )
|
||||
import MetaBrush.Unique
|
||||
( newUniqueSupply
|
||||
, Unique, freshUnique
|
||||
, uniqueMapFromList
|
||||
)
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
( getDataFileName )
|
||||
import MetaBrush.Application
|
||||
( runApplication )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -179,305 +44,14 @@ main = do
|
|||
setNumCapabilities caps
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Initialise state
|
||||
-- Run GTK application
|
||||
|
||||
uniqueSupply <- newUniqueSupply
|
||||
application <- GTK.applicationNew ( Just "com.calligraphy.MetaBrush" ) [ GIO.ApplicationFlagsNonUnique ]
|
||||
GIO.applicationRegister application ( Nothing @GIO.Cancellable )
|
||||
void $ GIO.onApplicationActivate application ( runApplication application )
|
||||
exitCode <- GIO.applicationRun application Nothing
|
||||
GObject.objectUnref application
|
||||
|
||||
circleBrush <- Asset.Brushes.circle uniqueSupply
|
||||
circleBrushUnique <- runReaderT freshUnique uniqueSupply
|
||||
docUnique <- runReaderT freshUnique uniqueSupply
|
||||
strokeUnique <- runReaderT freshUnique uniqueSupply
|
||||
|
||||
let
|
||||
|
||||
testBrushes :: HashMap Brush Unique
|
||||
testBrushes = HashMap.fromList
|
||||
[ ( circleBrush, circleBrushUnique ) ]
|
||||
|
||||
testDocuments :: Map Unique DocumentHistory
|
||||
testDocuments = fmap newHistory $ uniqueMapFromList
|
||||
[ emptyDocument "Test" docUnique
|
||||
& ( field' @"documentContent" . field' @"strokes" ) .~
|
||||
[ Stroke
|
||||
{ strokeName = "Stroke 1"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = strokeUnique
|
||||
, strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
|
||||
, strokeSpline =
|
||||
Spline
|
||||
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
||||
, splineCurves = OpenCurves $ Seq.fromList
|
||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
|
||||
]
|
||||
}
|
||||
}
|
||||
]
|
||||
& ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
|
||||
]
|
||||
where
|
||||
mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
|
||||
mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
|
||||
|
||||
recomputeStrokesTVar <- STM.newTVarIO @Bool False
|
||||
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
|
||||
brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
|
||||
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
|
||||
toolTVar <- STM.newTVarIO @Tool Selection
|
||||
modeTVar <- STM.newTVarIO @Mode PathMode
|
||||
debugTVar <- STM.newTVarIO @Bool False
|
||||
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
|
||||
fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
|
||||
showGuidesTVar <- STM.newTVarIO @Bool True
|
||||
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
||||
fitParametersTVar <- STM.newTVarIO @FitParameters
|
||||
( FitParameters
|
||||
{ maxSubdiv = 6
|
||||
, nbSegments = 12
|
||||
, dist_tol = 5e-3
|
||||
, t_tol = 1e-4
|
||||
, maxIters = 100
|
||||
}
|
||||
)
|
||||
|
||||
-- Put all these stateful variables in a record for conciseness.
|
||||
let
|
||||
variables :: Variables
|
||||
variables = Variables {..}
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Initialise GTK
|
||||
|
||||
void $ GTK.init Nothing
|
||||
Just screen <- GDK.screenGetDefault
|
||||
|
||||
themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
|
||||
cssProvider <- GTK.cssProviderNew
|
||||
GTK.cssProviderLoadFromPath cssProvider themePath
|
||||
GTK.styleContextAddProviderForScreen screen cssProvider 1000
|
||||
|
||||
window <- GTK.windowNew GTK.WindowTypeToplevel
|
||||
windowWidgetPath <- GTK.widgetGetPath window
|
||||
widgetAddClass window "window"
|
||||
GTK.setWindowResizable window True
|
||||
GTK.setWindowDecorated window False
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
GTK.windowSetDefaultSize window 1024 768
|
||||
GTK.widgetAddEvents window
|
||||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
||||
|
||||
let
|
||||
baseMinWidth, baseMinHeight :: Int32
|
||||
baseMinWidth = 480
|
||||
baseMinHeight = 240
|
||||
|
||||
windowGeometry <- GDK.newZeroGeometry
|
||||
GDK.setGeometryMinWidth windowGeometry baseMinWidth
|
||||
GDK.setGeometryMinHeight windowGeometry baseMinHeight
|
||||
GTK.windowSetGeometryHints window ( Nothing @GTK.Widget )
|
||||
( Just windowGeometry )
|
||||
[ GDK.WindowHintsMinSize ]
|
||||
|
||||
iconPath <- Directory.canonicalizePath =<< Cabal.getDataFileName "icon.png"
|
||||
GTK.windowSetIconFromFile window iconPath
|
||||
|
||||
colours <- getColours windowWidgetPath
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Create base UI elements
|
||||
|
||||
baseOverlay <- GTK.overlayNew
|
||||
GTK.setContainerChild window baseOverlay
|
||||
|
||||
uiGrid <- GTK.gridNew
|
||||
GTK.setContainerChild baseOverlay uiGrid
|
||||
|
||||
logo <- GTK.boxNew GTK.OrientationVertical 0
|
||||
titleBar <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
toolBar <- GTK.boxNew GTK.OrientationVertical 0
|
||||
mainPane <- GTK.panedNew GTK.OrientationHorizontal
|
||||
panelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
GTK.gridAttach uiGrid logo 0 0 1 2
|
||||
GTK.gridAttach uiGrid titleBar 1 0 2 1
|
||||
GTK.gridAttach uiGrid toolBar 0 2 2 1
|
||||
GTK.gridAttach uiGrid mainPane 2 2 1 1
|
||||
|
||||
mainView <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
GTK.panedPack1 mainPane mainView True False
|
||||
GTK.panedPack2 mainPane panelBox False False
|
||||
|
||||
viewportGrid <- GTK.gridNew
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Background
|
||||
|
||||
widgetAddClass uiGrid "bg"
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Title bar
|
||||
|
||||
widgetAddClass titleBar "titleBar"
|
||||
|
||||
--------
|
||||
-- Logo
|
||||
|
||||
widgetAddClass logo "logo"
|
||||
|
||||
logoArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart logo logoArea True True 0
|
||||
|
||||
void $ GTK.onWidgetDraw logoArea
|
||||
$ Cairo.renderWithContext ( drawLogo colours )
|
||||
|
||||
------------
|
||||
-- Title
|
||||
|
||||
title <- GTK.labelNew ( Just "MetaBrush" )
|
||||
widgetAddClasses title [ "text", "title", "plain" ]
|
||||
GTK.boxSetCenterWidget titleBar ( Just title )
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Main viewport
|
||||
|
||||
viewport@( Viewport {..} ) <- createViewport viewportGrid
|
||||
|
||||
-----------------
|
||||
-- Viewport rendering
|
||||
|
||||
-- Update the document render data in a separate thread.
|
||||
_ <- forkIO $ forever do
|
||||
getRenderDoc <- STM.atomically do
|
||||
needsRecomputation <- STM.readTVar recomputeStrokesTVar
|
||||
case needsRecomputation of
|
||||
False -> STM.retry
|
||||
True -> do
|
||||
mbDocNow <- fmap present <$> activeDocument variables
|
||||
case mbDocNow of
|
||||
Nothing -> pure ( pure . const $ blankRender colours )
|
||||
Just doc -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
mbMousePos <- STM.readTVar mousePosTVar
|
||||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
mbPartialPath <- STM.readTVar partialPathTVar
|
||||
mode <- STM.readTVar modeTVar
|
||||
showGuides <- STM.readTVar showGuidesTVar
|
||||
debug <- STM.readTVar debugTVar
|
||||
fitParameters <- STM.readTVar fitParametersTVar
|
||||
STM.writeTVar recomputeStrokesTVar False
|
||||
let
|
||||
addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
|
||||
addRulers newRender viewportSize = do
|
||||
newRender viewportSize
|
||||
renderRuler
|
||||
colours viewportSize ViewportOrigin viewportSize
|
||||
mbMousePos mbHoldAction showGuides
|
||||
doc
|
||||
pure
|
||||
( addRulers <$> getDocumentRender
|
||||
colours fitParameters mode debug
|
||||
modifiers mbMousePos mbHoldAction mbPartialPath
|
||||
doc
|
||||
)
|
||||
renderDoc <- stToIO getRenderDoc
|
||||
STM.atomically do
|
||||
STM.writeTVar documentRenderTVar renderDoc
|
||||
void do
|
||||
GDK.threadsAddIdle GLib.PRIORITY_HIGH_IDLE
|
||||
( False <$ GTK.widgetQueueDraw viewportDrawingArea )
|
||||
|
||||
-- Render the document using the latest available draw data.
|
||||
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
-- Get the Cairo instructions for rendering the current document
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
|
||||
render <- case mbDoc of
|
||||
Nothing -> pure ( blankRender colours )
|
||||
Just _ -> STM.atomically do
|
||||
render <- STM.readTVar documentRenderTVar
|
||||
pure ( render ( viewportWidth, viewportHeight ) )
|
||||
Cairo.renderWithContext render ctx
|
||||
pure True
|
||||
|
||||
for_ [ ( rulerCornerDrawingArea , RulerCorner )
|
||||
, ( topRulerDrawingArea , TopRuler )
|
||||
, ( leftRulerDrawingArea , LeftRuler )
|
||||
] \ ( rulerDrawingArea, ruler ) -> do
|
||||
void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
width <- GTK.widgetGetAllocatedWidth rulerDrawingArea
|
||||
height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
|
||||
mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
|
||||
mbMousePos <- STM.readTVar mousePosTVar
|
||||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
showGuides <- STM.readTVar showGuidesTVar
|
||||
pure do
|
||||
renderRuler
|
||||
colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
|
||||
mbMousePos mbHoldAction showGuides
|
||||
doc
|
||||
for_ mbRender \ render -> Cairo.renderWithContext render ctx
|
||||
|
||||
pure True
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Tool bar
|
||||
|
||||
_ <- createToolBar variables colours toolBar
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Info bar
|
||||
|
||||
infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
|
||||
|
||||
rec
|
||||
|
||||
---------------------------------------------------------
|
||||
-- File bar
|
||||
|
||||
fileBar@( FileBar { fileBarBox } ) <-
|
||||
createFileBar
|
||||
colours
|
||||
variables
|
||||
window titleBar title viewport infoBar menu
|
||||
|
||||
------------
|
||||
-- Menu bar
|
||||
|
||||
let
|
||||
uiElements :: UIElements
|
||||
uiElements = UIElements { menu, fileBar, .. }
|
||||
|
||||
menu <- createMenuBar uiElements variables colours
|
||||
|
||||
GTK.boxPackStart mainView fileBarBox False False 0
|
||||
GTK.boxPackStart mainView viewportGrid True True 0
|
||||
GTK.boxPackStart mainView infoBarArea False False 0
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels
|
||||
|
||||
createPanelBar panelBox
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
handleEvents uiElements variables
|
||||
|
||||
---------------------------------------------------------
|
||||
-- GTK main loop
|
||||
|
||||
GTK.widgetShowAll window
|
||||
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
|
||||
updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
|
||||
GTK.main
|
||||
|
||||
exitSuccess
|
||||
case exitCode of
|
||||
0 -> exitSuccess
|
||||
_ -> exitWith ( ExitFailure $ fromIntegral exitCode )
|
||||
|
|
|
|||
|
|
@ -1,13 +1,17 @@
|
|||
* {
|
||||
|
||||
.metabrush * {
|
||||
all: unset;
|
||||
}
|
||||
|
||||
|
||||
/* Colors parsed by application */
|
||||
.bg {
|
||||
background-color: rgb(41, 40, 40);
|
||||
color: rgb(41, 40, 40);
|
||||
}
|
||||
.active {
|
||||
background-color: rgb(72,70,61);
|
||||
color: rgb(72,70,61);
|
||||
}
|
||||
.close {
|
||||
color: rgb(181,43,43);
|
||||
|
|
@ -65,21 +69,24 @@
|
|||
}
|
||||
.viewport {
|
||||
background-color: rgb(236, 223, 210);
|
||||
-GtkWidget-window-dragging: false;
|
||||
color: rgb(236, 223, 210);
|
||||
min-width: 120px;
|
||||
min-height: 90px;
|
||||
}
|
||||
.viewportScrollbar {
|
||||
background-color: rgba(45, 39, 39, 0.66);
|
||||
color: rgba(45, 39, 39, 0.66);
|
||||
margin: 4px;
|
||||
min-width: 8px;
|
||||
min-height: 8px;
|
||||
}
|
||||
.tabScrollbar {
|
||||
background-color: rgba(48, 45, 38, 0.66);
|
||||
color: rgba(48, 45, 38, 0.66);
|
||||
}
|
||||
.ruler {
|
||||
background-color: rgb(237, 226, 154);
|
||||
color: rgb(237, 226, 154);
|
||||
min-width: 16px;
|
||||
min-height: 16px;
|
||||
background-size: 16px 16px;
|
||||
|
|
@ -97,7 +104,7 @@
|
|||
color: rgba(156, 231, 255, 0.5);
|
||||
}
|
||||
.selected {
|
||||
color: rgba(161,201,236,0.5)
|
||||
color: rgba(161,201,236,0.5);
|
||||
}
|
||||
.selectedOutline {
|
||||
color: rgb(74,150,218);
|
||||
|
|
@ -113,10 +120,17 @@ tooltip {
|
|||
border: 1px solid rgb(28,25,25);
|
||||
}
|
||||
|
||||
|
||||
.window, .dialog {
|
||||
-GtkWidget-window-dragging: true;
|
||||
border-radius: 0px;
|
||||
border-color: rgb(28,25,25);
|
||||
box-shadow:
|
||||
0px 3px 9px 1px rgba(0,0,0,0),
|
||||
0px 2px 6px 2px rgba(0,0,0,0.2),
|
||||
0px 0px 0px 1px rgba(0,0,0,0.18);
|
||||
}
|
||||
|
||||
|
||||
/* Basic text colour */
|
||||
|
||||
/* Basic text font */
|
||||
|
|
@ -193,6 +207,7 @@ tooltip {
|
|||
.titleBar {
|
||||
min-height: 24px;
|
||||
font-size: 12px;
|
||||
background-color: rgb(41, 40, 40);
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
@ -228,66 +243,65 @@ tooltip {
|
|||
background-color: #eadfcc;
|
||||
}
|
||||
|
||||
/* Menu bar */
|
||||
|
||||
.menuBar {
|
||||
padding-left: 4px;
|
||||
.menu label {
|
||||
color:rgb(212, 190, 152);
|
||||
}
|
||||
|
||||
.menuItem {
|
||||
color: rgba(212, 190, 152,0.5);
|
||||
background-color: rgb(41, 40, 40);
|
||||
.menu :disabled {
|
||||
color:rgb(149,149,149);
|
||||
}
|
||||
|
||||
.menu item {
|
||||
padding-left: 8px;
|
||||
padding-right: 8px;
|
||||
margin-left: 0px;
|
||||
color: rgb(212, 190, 152);
|
||||
border-top: 2px solid rgb(41, 40, 40);
|
||||
}
|
||||
|
||||
/* Menu item hover effect (workaround) */
|
||||
.menuItem:selected {
|
||||
.menu :hover {
|
||||
color: rgb(212, 190, 152);
|
||||
border-color: rgb(72,70,61);
|
||||
color: rgb(212, 190, 152);
|
||||
}
|
||||
|
||||
/* Styling for active menu item */
|
||||
.menuItem:active, .menuItem:checked, .menuItem:hover {
|
||||
border-color: rgb(234,223,204);
|
||||
.menu item > * :hover {
|
||||
border-color: rgb(212, 190, 152);
|
||||
background-color: rgb(72,70,61);
|
||||
color: rgb(212, 190, 152);
|
||||
}
|
||||
|
||||
.menuItem > * > * {
|
||||
box-shadow: 2px 4px 3px -1px rgba(28,25,25,0.5);
|
||||
border: 1px solid rgb(28,25,25);
|
||||
border-top: 1px solid rgb(72,70,61);
|
||||
color: rgb(212, 190, 152);
|
||||
/* Top-level menu items */
|
||||
|
||||
/* TODO: shadows not working properly */
|
||||
.menu item > popover > contents > stack > box > box {
|
||||
box-shadow: 0 0 1px 2px rgba(0,0,0,0.5);
|
||||
}
|
||||
|
||||
.submenuItem {
|
||||
color: rgb(212, 190, 152);
|
||||
padding-top: 4px;
|
||||
padding-bottom: 4px;
|
||||
padding-left: 10px;
|
||||
padding-right: 10px;
|
||||
/* Submenus without separators */
|
||||
.menu item > popover > contents > stack > box > box > modelbutton {
|
||||
background-color: rgb(41, 40, 40);
|
||||
color: rgb(72,70,61);
|
||||
border-top: 0px;
|
||||
border-left: 2px solid rgb(41, 40, 40);
|
||||
padding: 2px 10px 6px 10px;
|
||||
}
|
||||
|
||||
.submenuItem:hover{
|
||||
/* Submenus with separators */
|
||||
.menu item > popover > contents > stack > box > box > box > box > modelbutton {
|
||||
background-color: rgb(41, 40, 40);
|
||||
color: rgb(72,70,61);
|
||||
border-top: 0px;
|
||||
border-left: 2px solid rgb(41, 40, 40);
|
||||
padding: 2px 10px 6px 10px;
|
||||
}
|
||||
|
||||
.menu item > popover > contents > stack > box > box > box > separator,
|
||||
.menu item > popover > contents > stack > box > box > box > separator :hover {
|
||||
background-color: rgb(72,70,61);
|
||||
padding: 1px 0px 0px 1px;
|
||||
}
|
||||
|
||||
.submenuItem:disabled {
|
||||
color: rgb(149,149,149);
|
||||
}
|
||||
|
||||
.submenuSeparator {
|
||||
background-color: rgb(28,25,25);
|
||||
padding-top: 1px;
|
||||
}
|
||||
|
||||
.submenuItem:hover {
|
||||
border-color: rgb(234,223,204);
|
||||
}
|
||||
|
||||
.accelLabel {
|
||||
padding: 2px 8px 2px 0px;
|
||||
|
|
@ -441,7 +455,6 @@ tooltip {
|
|||
.infoBar {
|
||||
min-height: 40px;
|
||||
font-size: 10px;
|
||||
-GtkWidget-window-dragging: true;
|
||||
}
|
||||
|
||||
.infoBarInfo {
|
||||
|
|
|
|||
|
|
@ -30,18 +30,6 @@ source-repository-package
|
|||
location: https://github.com/sheaf/generic-lens
|
||||
tag: 8d3f0b405894ecade5821c99dcde6efb4a637363
|
||||
|
||||
-- GHC 9.0 compatibility for 'haskell-gi' and 'haskell-gi-base'
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/haskell-gi/haskell-gi
|
||||
tag: cc6c25a32288ceef79585e8bba5f197065fb477c
|
||||
subdir: .
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/haskell-gi/haskell-gi
|
||||
tag: cc6c25a32288ceef79585e8bba5f197065fb477c
|
||||
subdir: base
|
||||
|
||||
-- superrecord API improvements
|
||||
source-repository-package
|
||||
type: git
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -24,11 +27,13 @@ import Data.Foldable
|
|||
import Data.Int
|
||||
( Int32 )
|
||||
import Data.Maybe
|
||||
( listToMaybe )
|
||||
( catMaybes, fromMaybe )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -59,9 +64,22 @@ import Data.Generics.Product.Fields
|
|||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
-- gi-gobject
|
||||
import qualified GI.GObject as GObject
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- haskell-gi-base
|
||||
import qualified Data.GI.Base as GI
|
||||
|
||||
-- hashable
|
||||
import Data.Hashable
|
||||
( Hashable )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( over, set )
|
||||
|
|
@ -129,9 +147,7 @@ import MetaBrush.UI.Coordinates
|
|||
import MetaBrush.UI.InfoBar
|
||||
( updateInfoBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( TabLocation(..), newFileTab, removeFileTab )
|
||||
import MetaBrush.UI.Menu
|
||||
( MenuItem(..), Menu(..), ViewMenu(..) )
|
||||
( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
|
|
@ -139,10 +155,22 @@ import MetaBrush.UI.Viewport
|
|||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
( (>=?=>), (>>?=)
|
||||
, widgetAddClass, widgetAddClasses
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ActionName
|
||||
= AppAction { actionSimpleName :: !Text }
|
||||
| WinAction { actionSimpleName :: !Text }
|
||||
deriving stock ( Eq, Ord, Show, Generic )
|
||||
deriving anyclass Hashable
|
||||
|
||||
actionPrefix :: ActionName -> Text
|
||||
actionPrefix ( AppAction _ ) = "app."
|
||||
actionPrefix ( WinAction _ ) = "win."
|
||||
|
||||
class HandleAction action where
|
||||
handleAction :: UIElements -> Variables -> action -> IO ()
|
||||
|
||||
|
|
@ -161,7 +189,7 @@ data NewFile = NewFile TabLocation
|
|||
|
||||
instance HandleAction NewFile where
|
||||
handleAction uiElts vars ( NewFile tabLoc ) =
|
||||
newFileTab False uiElts vars Nothing tabLoc
|
||||
newFileTab uiElts vars Nothing tabLoc
|
||||
|
||||
---------------
|
||||
-- Open file --
|
||||
|
|
@ -178,41 +206,53 @@ instance HandleAction OpenFile where
|
|||
( Just "Open" )
|
||||
( Just "Cancel" )
|
||||
GTK.fileChooserSetSelectMultiple fileChooser True
|
||||
GTK.fileChooserSetAction fileChooser GTK.FileChooserActionOpen
|
||||
GTK.nativeDialogSetModal fileChooser True
|
||||
fileFilter <- GTK.fileFilterNew
|
||||
GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
|
||||
GTK.fileFilterAddPattern fileFilter "*.mb"
|
||||
GTK.fileChooserAddFilter fileChooser fileFilter
|
||||
void $ GTK.nativeDialogRun fileChooser
|
||||
filePaths <- GTK.fileChooserGetFilenames fileChooser
|
||||
for_ filePaths \ filePath -> do
|
||||
knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
|
||||
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
|
||||
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
|
||||
case mbDoc of
|
||||
Left errMessage -> warningDialog window filePath errMessage
|
||||
Right doc -> do
|
||||
let
|
||||
newDocHist :: DocumentHistory
|
||||
newDocHist = newHistory doc
|
||||
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
|
||||
updateHistoryState uiElts ( Just newDocHist )
|
||||
GTK.nativeDialogShow fileChooser
|
||||
void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
|
||||
when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
|
||||
files <- GTK.fileChooserGetFiles fileChooser
|
||||
nbFiles <- GIO.listModelGetNItems files
|
||||
fileNames <- catMaybes <$>
|
||||
for [ ( 0 :: Int ) .. fromIntegral nbFiles - 1 ] \ i ->
|
||||
GIO.listModelGetItem files ( fromIntegral i ) >>?=
|
||||
( GI.castTo GIO.File >=?=> GIO.fileGetPath )
|
||||
for_ fileNames \ filePath -> do
|
||||
knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
|
||||
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
|
||||
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
|
||||
case mbDoc of
|
||||
Left errMessage -> warningDialog window filePath errMessage
|
||||
Right doc -> do
|
||||
let
|
||||
newDocHist :: DocumentHistory
|
||||
newDocHist = newHistory doc
|
||||
newFileTab uiElts vars ( Just newDocHist ) tabLoc
|
||||
updateHistoryState uiElts ( Just newDocHist )
|
||||
GObject.objectUnref files
|
||||
|
||||
warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO ()
|
||||
warningDialog
|
||||
:: ( Show errMess, GTK.IsWindow window )
|
||||
=> window -> FilePath -> errMess -> IO ()
|
||||
warningDialog window filePath errMess = do
|
||||
dialog <- GTK.new GTK.MessageDialog []
|
||||
GTK.setMessageDialogText dialog
|
||||
( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
|
||||
GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
|
||||
GTK.setWindowResizable dialog False
|
||||
GTK.setWindowResizable dialog True
|
||||
GTK.setWindowDecorated dialog False
|
||||
GTK.windowSetTransientFor dialog ( Just window )
|
||||
GTK.windowSetModal dialog True
|
||||
widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
|
||||
closeButton <- GTK.dialogAddButton dialog "OK" 1
|
||||
widgetAddClass closeButton "dialogButton"
|
||||
_ <- GTK.dialogRun dialog
|
||||
GTK.widgetDestroy dialog
|
||||
GTK.widgetShow dialog
|
||||
void $ GTK.afterDialogResponse dialog \ _ -> do
|
||||
GTK.windowDestroy dialog
|
||||
|
||||
-----------------
|
||||
-- Open folder --
|
||||
|
|
@ -228,30 +268,34 @@ instance HandleAction OpenFolder where
|
|||
GTK.FileChooserActionSelectFolder
|
||||
( Just "Select Folder" )
|
||||
( Just "Cancel" )
|
||||
GTK.fileChooserSetSelectMultiple fileChooser True
|
||||
GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSelectFolder
|
||||
GTK.nativeDialogSetModal fileChooser True
|
||||
void $ GTK.nativeDialogRun fileChooser
|
||||
folderPaths <- GTK.fileChooserGetFilenames fileChooser
|
||||
for_ folderPaths \ folderPath -> do
|
||||
exists <- doesDirectoryExist folderPath
|
||||
when exists do
|
||||
filePaths <- listDirectory folderPath
|
||||
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
|
||||
knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
|
||||
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath </> filePath )
|
||||
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
|
||||
case mbDoc of
|
||||
Left errMessage -> warningDialog window filePath errMessage
|
||||
Right doc -> do
|
||||
let
|
||||
newDocHist :: DocumentHistory
|
||||
newDocHist = newHistory doc
|
||||
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
|
||||
updateHistoryState uiElts ( Just newDocHist )
|
||||
GTK.nativeDialogShow fileChooser
|
||||
void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
|
||||
when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
|
||||
folder <- GTK.fileChooserGetFile fileChooser
|
||||
mbFolderPath <- GIO.fileGetPath folder
|
||||
for_ mbFolderPath \ folderPath -> do
|
||||
exists <- doesDirectoryExist folderPath
|
||||
when exists do
|
||||
filePaths <- listDirectory folderPath
|
||||
for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
|
||||
knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
|
||||
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath </> filePath )
|
||||
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
|
||||
case mbDoc of
|
||||
Left errMessage -> warningDialog window filePath errMessage
|
||||
Right doc -> do
|
||||
let
|
||||
newDocHist :: DocumentHistory
|
||||
newDocHist = newHistory doc
|
||||
newFileTab uiElts vars ( Just newDocHist ) tabLoc
|
||||
updateHistoryState uiElts ( Just newDocHist )
|
||||
GObject.objectUnref folder
|
||||
|
||||
---------------
|
||||
-- Save file --
|
||||
---------------
|
||||
--------------------
|
||||
-- Save & Save as --
|
||||
--------------------
|
||||
|
||||
data Save = Save
|
||||
deriving stock Show
|
||||
|
|
@ -260,6 +304,12 @@ instance HandleAction Save where
|
|||
handleAction uiElts vars _ =
|
||||
save uiElts vars True
|
||||
|
||||
data SaveAs = SaveAs
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction SaveAs where
|
||||
handleAction uiElts vars _ = saveAs uiElts vars True
|
||||
|
||||
save :: UIElements -> Variables -> Bool -> IO ()
|
||||
save uiElts vars keepOpen = do
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||
|
|
@ -276,48 +326,42 @@ save uiElts vars keepOpen = do
|
|||
modif = if keepOpen then SaveDocument Nothing else CloseDocument
|
||||
pure $ UpdateDocAndThen modif ( saveDocument filePath doc )
|
||||
|
||||
-------------
|
||||
-- Save as --
|
||||
-------------
|
||||
|
||||
data SaveAs = SaveAs
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction SaveAs where
|
||||
handleAction uiElts vars _ = saveAs uiElts vars True
|
||||
|
||||
saveAs :: UIElements -> Variables -> Bool -> IO ()
|
||||
saveAs uiElts vars keepOpen = do
|
||||
mbSavePath <- askForSavePath uiElts
|
||||
for_ mbSavePath \ savePath ->
|
||||
saveAs uiElts vars keepOpen =
|
||||
withSavePath uiElts \ savePath ->
|
||||
modifyingCurrentDocument uiElts vars \ doc -> do
|
||||
let
|
||||
modif :: DocumentUpdate
|
||||
modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
|
||||
pure $ UpdateDocAndThen modif ( saveDocument savePath doc )
|
||||
|
||||
askForSavePath :: UIElements -> IO ( Maybe FilePath )
|
||||
askForSavePath ( UIElements {..} ) = do
|
||||
withSavePath :: UIElements -> ( FilePath -> IO () ) -> IO ()
|
||||
withSavePath ( UIElements {..} ) action = do
|
||||
fileChooser <-
|
||||
GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
|
||||
GTK.FileChooserActionSave
|
||||
( Just "Save" )
|
||||
( Just "Cancel" )
|
||||
GTK.nativeDialogSetModal fileChooser True
|
||||
GTK.fileChooserSetDoOverwriteConfirmation fileChooser True
|
||||
GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSave
|
||||
fileFilter <- GTK.fileFilterNew
|
||||
GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
|
||||
GTK.fileFilterAddPattern fileFilter "*.mb"
|
||||
GTK.fileChooserAddFilter fileChooser fileFilter
|
||||
void $ GTK.nativeDialogRun fileChooser
|
||||
fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
|
||||
where
|
||||
fullFilePath :: FilePath -> FilePath
|
||||
fullFilePath fp
|
||||
| ".mb" <- takeExtension fp
|
||||
= fp
|
||||
| otherwise
|
||||
= fp <.> "mb"
|
||||
GTK.nativeDialogShow fileChooser
|
||||
void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
|
||||
when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
|
||||
saveFile <- GTK.fileChooserGetFile fileChooser
|
||||
mbSavePath <- fmap fullFilePath <$> GIO.fileGetPath saveFile
|
||||
for_ mbSavePath action
|
||||
GObject.objectUnref saveFile
|
||||
where
|
||||
fullFilePath :: FilePath -> FilePath
|
||||
fullFilePath fp
|
||||
| ".mb" <- takeExtension fp
|
||||
= fp
|
||||
| otherwise
|
||||
= fp <.> "mb"
|
||||
|
||||
-----------
|
||||
-- Close --
|
||||
|
|
@ -326,7 +370,7 @@ askForSavePath ( UIElements {..} ) = do
|
|||
data Close
|
||||
= CloseActive -- ^ Close active document.
|
||||
| CloseThis -- ^ Close a specific tab.
|
||||
{ docToClose :: Unique }
|
||||
{ docToClose :: !Unique }
|
||||
deriving stock Show
|
||||
|
||||
pattern JustClose, SaveAndClose, CancelClose :: Int32
|
||||
|
|
@ -364,19 +408,20 @@ instance HandleAction Close where
|
|||
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
|
||||
GTK.dialogSetDefaultResponse dialog 1
|
||||
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
|
||||
choice <- GTK.dialogRun dialog
|
||||
GTK.widgetDestroy dialog
|
||||
case choice of
|
||||
JustClose -> closeDocument isActiveDoc documentUnique
|
||||
SaveAndClose -> save uiElts vars False
|
||||
_ -> pure ()
|
||||
GTK.widgetShow dialog
|
||||
void $ GTK.onDialogResponse dialog \ choice -> do
|
||||
case choice of
|
||||
JustClose -> closeDocument isActiveDoc documentUnique
|
||||
SaveAndClose -> save uiElts vars False
|
||||
_ -> pure ()
|
||||
GTK.windowDestroy dialog
|
||||
| otherwise
|
||||
-> closeDocument isActiveDoc documentUnique
|
||||
|
||||
where
|
||||
closeDocument :: Bool -> Unique -> IO ()
|
||||
closeDocument isActiveDoc unique = do
|
||||
removeFileTab vars unique
|
||||
removeFileTab uiElts vars unique
|
||||
when isActiveDoc do
|
||||
uiUpdateAction <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar Nothing
|
||||
|
|
@ -390,22 +435,43 @@ instance HandleAction Close where
|
|||
-- Switch document --
|
||||
---------------------
|
||||
|
||||
data SwitchTo = SwitchTo Unique
|
||||
data SwitchFromTo =
|
||||
SwitchFromTo
|
||||
{ mbPrevActiveDocUnique :: !( Maybe Unique )
|
||||
, newActiveDocUnique :: !Unique
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction SwitchTo where
|
||||
instance HandleAction SwitchFromTo where
|
||||
handleAction
|
||||
uiElts
|
||||
vars@( Variables {..} )
|
||||
( SwitchTo newUnique ) = do
|
||||
uiUpdateAction <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
|
||||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
pure do
|
||||
uiUpdateAction
|
||||
updateHistoryState uiElts mbHist
|
||||
uiUpdateAction
|
||||
( SwitchFromTo { mbPrevActiveDocUnique, newActiveDocUnique } )
|
||||
| mbPrevActiveDocUnique == Just newActiveDocUnique
|
||||
= do
|
||||
mbActiveTab <- Map.lookup newActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar
|
||||
for_ mbActiveTab \ ( FileBarTab { fileBarTab = activeTab, fileBarTabButton = activeTabButton } ) -> do
|
||||
GTK.toggleButtonSetActive activeTabButton True
|
||||
flags <- GTK.widgetGetStateFlags activeTab
|
||||
GTK.widgetSetStateFlags activeTab
|
||||
( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
|
||||
True
|
||||
| otherwise
|
||||
= do
|
||||
uiUpdateAction <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique )
|
||||
mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
|
||||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
pure do
|
||||
uiUpdateAction
|
||||
for_ mbPrevActiveDocUnique \ prevActiveDocUnique -> do
|
||||
mbPrevActiveTab <- Map.lookup prevActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar
|
||||
for_ mbPrevActiveTab \ ( FileBarTab { fileBarTab = prevActiveTab, fileBarTabButton = prevActiveTabButton } ) -> do
|
||||
GTK.toggleButtonSetActive prevActiveTabButton False
|
||||
flags <- GTK.widgetGetStateFlags prevActiveTab
|
||||
GTK.widgetSetStateFlags prevActiveTab ( filter (/= GTK.StateFlagsActive) flags ) True
|
||||
updateHistoryState uiElts mbHist
|
||||
uiUpdateAction
|
||||
|
||||
--------------
|
||||
-- Quitting --
|
||||
|
|
@ -415,10 +481,11 @@ data Quit = Quit
|
|||
deriving stock Show
|
||||
|
||||
instance HandleAction Quit where
|
||||
handleAction ( UIElements { window } ) _ _ = quitEverything window
|
||||
handleAction ( UIElements { application, window } ) _ _ =
|
||||
quitEverything application window
|
||||
|
||||
quitEverything :: GTK.Window -> IO ()
|
||||
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
|
||||
quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO ()
|
||||
quitEverything = GTK.applicationRemoveWindow
|
||||
|
||||
----------------
|
||||
-- Undo & Redo --
|
||||
|
|
@ -556,17 +623,20 @@ data ToggleGuides = ToggleGuides
|
|||
deriving stock Show
|
||||
|
||||
instance HandleAction ToggleGuides where
|
||||
handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do
|
||||
guidesWereShown <- STM.atomically do
|
||||
handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do
|
||||
_guidesWereShown <- STM.atomically do
|
||||
guidesWereShown <- STM.readTVar showGuidesTVar
|
||||
STM.writeTVar showGuidesTVar ( not guidesWereShown )
|
||||
pure guidesWereShown
|
||||
let
|
||||
newText :: Text
|
||||
newText
|
||||
| guidesWereShown = "Show guides"
|
||||
| otherwise = "Hide guides"
|
||||
GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText
|
||||
--let
|
||||
-- newText :: Text
|
||||
-- newText
|
||||
-- | guidesWereShown = "Show guides"
|
||||
-- | otherwise = "Hide guides"
|
||||
-- toggleGuidesWidget :: GTK.Button
|
||||
-- toggleGuidesWidget = menuItemWidget . toggleGuides . sectionItems . viewMenu4 . menuItemSubmenu . view
|
||||
-- $ menuObject
|
||||
--GTK.buttonSetLabel toggleGuidesWidget newText
|
||||
STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
|
||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetQueueDraw drawingArea
|
||||
|
|
@ -813,7 +883,7 @@ instance HandleAction MouseRelease where
|
|||
1 -> do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
|
|
@ -835,7 +905,8 @@ instance HandleAction MouseRelease where
|
|||
changeText = "Create guide"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
| otherwise
|
||||
-> pure Don'tModifyDoc
|
||||
-> pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange doc )
|
||||
-- ^^ force an UI update when releasing a guide inside a ruler area
|
||||
where
|
||||
createGuide :: Bool
|
||||
createGuide
|
||||
|
|
@ -991,29 +1062,27 @@ instance HandleAction MouseRelease where
|
|||
-- Scrolling --
|
||||
---------------
|
||||
|
||||
data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
|
||||
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction Scroll where
|
||||
handleAction
|
||||
uiElts@( UIElements { viewport = Viewport {..} } )
|
||||
uiElts
|
||||
vars@( Variables {..} )
|
||||
( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
|
||||
( Scroll mbMousePos ( Vector2D dx dy ) ) = do
|
||||
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
--viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
--viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
|
||||
unless ( dx == 0 && dy == 0 ) do
|
||||
modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
|
||||
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
|
||||
mousePos :: Point2D Double
|
||||
mousePos = toViewport ( Point2D x y )
|
||||
mousePos = fromMaybe oldCenter mbMousePos
|
||||
finalMousePos :: Point2D Double
|
||||
newDoc :: Document
|
||||
newDoc
|
||||
( newDoc, finalMousePos )
|
||||
-- Zooming using 'Control'.
|
||||
| any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||||
= let
|
||||
|
|
@ -1027,28 +1096,21 @@ instance HandleAction Scroll where
|
|||
newCenter
|
||||
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
|
||||
• oldCenter
|
||||
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
|
||||
in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
|
||||
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||||
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
|
||||
-- Vertical scrolling.
|
||||
| otherwise
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
finalZoomFactor :: Double
|
||||
finalZoomFactor = zoomFactor newDoc
|
||||
finalCenter :: Point2D Double
|
||||
finalCenter = viewportCenter newDoc
|
||||
toFinalViewport :: Point2D Double -> Point2D Double
|
||||
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
|
||||
finalMousePos :: Point2D Double
|
||||
finalMousePos = toFinalViewport ( Point2D x y )
|
||||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
|
||||
for_ mbMousePos \ _ ->
|
||||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
||||
|
||||
--------------------
|
||||
|
|
@ -1067,7 +1129,7 @@ instance HandleAction KeyboardPress where
|
|||
for_ ( modifierKey keyCode )
|
||||
( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
|
||||
|
||||
case keyCode of
|
||||
case fromIntegral keyCode of
|
||||
|
||||
GDK.KEY_Escape -> handleAction uiElts vars Quit
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
|
||||
module MetaBrush.Action where
|
||||
|
||||
-- base
|
||||
|
|
@ -7,6 +9,14 @@ import Data.Word
|
|||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- hashable
|
||||
import Data.Hashable
|
||||
( Hashable )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D, Vector2D )
|
||||
|
|
@ -21,6 +31,15 @@ import MetaBrush.Unique
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ActionName
|
||||
= AppAction { actionSimpleName :: !Text }
|
||||
| WinAction { actionSimpleName :: !Text }
|
||||
|
||||
instance Eq ActionName
|
||||
instance Ord ActionName
|
||||
instance Show ActionName
|
||||
instance Hashable ActionName
|
||||
|
||||
class HandleAction action where
|
||||
handleAction :: UIElements -> Variables -> action -> IO ()
|
||||
|
||||
|
|
@ -44,15 +63,19 @@ instance HandleAction SaveAs
|
|||
data Close
|
||||
= CloseActive
|
||||
| CloseThis
|
||||
{ docToClose :: Unique }
|
||||
{ docToClose :: !Unique }
|
||||
instance HandleAction Close
|
||||
|
||||
data SwitchTo = SwitchTo Unique
|
||||
instance HandleAction SwitchTo
|
||||
data SwitchFromTo =
|
||||
SwitchFromTo
|
||||
{ mbPrevActiveDocUnique :: !( Maybe Unique )
|
||||
, newActiveDocUnique :: !Unique
|
||||
}
|
||||
instance HandleAction SwitchFromTo
|
||||
|
||||
data Quit = Quit
|
||||
instance HandleAction Quit
|
||||
quitEverything :: GTK.Window -> IO ()
|
||||
quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO ()
|
||||
|
||||
data Undo = Undo
|
||||
instance HandleAction Undo
|
||||
|
|
@ -99,7 +122,7 @@ instance HandleAction MouseClick
|
|||
data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
||||
instance HandleAction MouseRelease
|
||||
|
||||
data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
|
||||
data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
|
||||
instance HandleAction Scroll
|
||||
|
||||
data KeyboardPress = KeyboardPress Word32
|
||||
|
|
|
|||
498
src/app/MetaBrush/Application.hs
Normal file
498
src/app/MetaBrush/Application.hs
Normal file
|
|
@ -0,0 +1,498 @@
|
|||
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NegativeLiterals #-}
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module MetaBrush.Application
|
||||
( runApplication )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( forever, void )
|
||||
import Control.Monad.ST
|
||||
( stToIO )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Function
|
||||
( (&) )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import GHC.Conc
|
||||
( forkIO )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
( empty )
|
||||
|
||||
-- directory
|
||||
import qualified System.Directory as Directory
|
||||
( canonicalizePath )
|
||||
|
||||
-- filepath
|
||||
import System.FilePath
|
||||
( (</>) )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- gi-cairo-render
|
||||
import qualified GI.Cairo.Render as Cairo
|
||||
( Render )
|
||||
|
||||
-- gi-cairo-connector
|
||||
import qualified GI.Cairo.Render.Connector as Cairo
|
||||
( renderWithContext )
|
||||
|
||||
-- gi-glib
|
||||
import qualified GI.GLib as GLib
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( (.~) )
|
||||
import Control.Lens.At
|
||||
( at )
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically, retry )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( newTVarIO, readTVar, writeTVar )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( (:=)(..), (&), rnil )
|
||||
|
||||
-- text
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
|
||||
-- unordered-containers
|
||||
import Data.HashMap.Strict
|
||||
( HashMap )
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
( fromList )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Cubic.Fit
|
||||
( FitParameters(..) )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
|
||||
import Math.Bezier.Stroke
|
||||
( invalidateCache )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Action
|
||||
( ActionOrigin(..) )
|
||||
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
|
||||
( circle )
|
||||
import MetaBrush.Asset.Colours
|
||||
( getColours )
|
||||
import MetaBrush.Asset.Logo
|
||||
( drawLogo )
|
||||
import MetaBrush.Brush
|
||||
( Brush, newBrushReference )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..)
|
||||
, HoldAction(..), PartialPath(..)
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( emptyDocument
|
||||
, Stroke(..), FocusState(..)
|
||||
, PointData(..)
|
||||
)
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..), newHistory )
|
||||
import MetaBrush.Document.Update
|
||||
( activeDocument, withActiveDocument )
|
||||
import MetaBrush.Event
|
||||
( handleEvents )
|
||||
import MetaBrush.Render.Document
|
||||
( blankRender, getDocumentRender )
|
||||
import MetaBrush.Render.Rulers
|
||||
( renderRuler )
|
||||
import MetaBrush.UI.FileBar
|
||||
( FileBar(..), FileBarTab, createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar(..), createInfoBar, updateInfoBar )
|
||||
import MetaBrush.UI.Menu
|
||||
( createMenuBar, createMenuActions )
|
||||
import MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..), createToolBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), ViewportEventControllers(..)
|
||||
, Ruler(..)
|
||||
, createViewport
|
||||
)
|
||||
import MetaBrush.Unique
|
||||
( newUniqueSupply
|
||||
, Unique, freshUnique
|
||||
, uniqueMapFromList
|
||||
)
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
( getDataDir, getDataFileName )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
runApplication :: GTK.Application -> IO ()
|
||||
runApplication application = do
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Initialise state
|
||||
|
||||
uniqueSupply <- newUniqueSupply
|
||||
|
||||
circleBrush <- Asset.Brushes.circle uniqueSupply
|
||||
circleBrushUnique <- runReaderT freshUnique uniqueSupply
|
||||
docUnique <- runReaderT freshUnique uniqueSupply
|
||||
strokeUnique <- runReaderT freshUnique uniqueSupply
|
||||
|
||||
let
|
||||
|
||||
testBrushes :: HashMap Brush Unique
|
||||
testBrushes = HashMap.fromList
|
||||
[ ( circleBrush, circleBrushUnique ) ]
|
||||
|
||||
testDocuments :: Map Unique DocumentHistory
|
||||
testDocuments = fmap newHistory $ uniqueMapFromList
|
||||
[ emptyDocument "Test" docUnique
|
||||
& ( field' @"documentContent" . field' @"strokes" ) .~
|
||||
[ Stroke
|
||||
{ strokeName = "Stroke 1"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = strokeUnique
|
||||
, strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
|
||||
, strokeSpline =
|
||||
Spline
|
||||
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
||||
, splineCurves = OpenCurves $ Seq.fromList
|
||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
|
||||
]
|
||||
}
|
||||
}
|
||||
]
|
||||
& ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
|
||||
]
|
||||
where
|
||||
mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
|
||||
mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
|
||||
|
||||
recomputeStrokesTVar <- STM.newTVarIO @Bool False
|
||||
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
|
||||
brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
|
||||
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
|
||||
toolTVar <- STM.newTVarIO @Tool Selection
|
||||
modeTVar <- STM.newTVarIO @Mode PathMode
|
||||
debugTVar <- STM.newTVarIO @Bool False
|
||||
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
|
||||
fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty
|
||||
showGuidesTVar <- STM.newTVarIO @Bool True
|
||||
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
||||
fitParametersTVar <- STM.newTVarIO @FitParameters
|
||||
( FitParameters
|
||||
{ maxSubdiv = 6
|
||||
, nbSegments = 12
|
||||
, dist_tol = 5e-3
|
||||
, t_tol = 1e-4
|
||||
, maxIters = 100
|
||||
}
|
||||
)
|
||||
|
||||
-- Put all these stateful variables in a record for conciseness.
|
||||
let
|
||||
variables :: Variables
|
||||
variables = Variables {..}
|
||||
|
||||
---------------------------------------------------------
|
||||
-- GTK UI
|
||||
|
||||
window <- GTK.applicationWindowNew application
|
||||
display <- GTK.rootGetDisplay window
|
||||
|
||||
dataPath <- Directory.canonicalizePath =<< Cabal.getDataDir
|
||||
themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
|
||||
cssProvider <- GTK.cssProviderNew
|
||||
GTK.cssProviderLoadFromPath cssProvider themePath
|
||||
GTK.styleContextAddProviderForDisplay display cssProvider 1000
|
||||
|
||||
windowKeys <- GTK.eventControllerKeyNew
|
||||
|
||||
GTK.eventControllerSetPropagationPhase windowKeys GTK.PropagationPhaseBubble
|
||||
|
||||
widgetAddClasses window [ "metabrush", "window" ]
|
||||
GTK.setWindowResizable window True
|
||||
GTK.setWindowDecorated window True
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
GTK.windowSetDefaultSize window 1024 768
|
||||
|
||||
GTK.windowSetIconName window ( Just "MetaBrush" )
|
||||
iconTheme <- GTK.iconThemeGetForDisplay display
|
||||
GTK.iconThemeAddSearchPath iconTheme ( dataPath </> "icons" )
|
||||
|
||||
colours <- getColours cssProvider
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Create base UI elements
|
||||
|
||||
baseOverlay <- GTK.overlayNew
|
||||
GTK.windowSetChild window ( Just baseOverlay )
|
||||
|
||||
uiGrid <- GTK.gridNew
|
||||
GTK.overlaySetChild baseOverlay ( Just uiGrid )
|
||||
|
||||
toolBar <- GTK.boxNew GTK.OrientationVertical 0
|
||||
mainPane <- GTK.panedNew GTK.OrientationHorizontal
|
||||
panelBox <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
GTK.gridAttach uiGrid toolBar 0 0 2 1
|
||||
GTK.gridAttach uiGrid mainPane 2 0 1 1
|
||||
|
||||
mainView <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
GTK.panedSetStartChild mainPane mainView
|
||||
GTK.panedSetEndChild mainPane panelBox
|
||||
|
||||
viewportGrid <- GTK.gridNew
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Background
|
||||
|
||||
widgetAddClass uiGrid "bg"
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Title bar
|
||||
|
||||
titleBar <- GTK.headerBarNew
|
||||
|
||||
GTK.windowSetTitlebar window ( Just titleBar )
|
||||
widgetAddClass titleBar "titleBar"
|
||||
|
||||
logo <- GTK.boxNew GTK.OrientationVertical 0
|
||||
GTK.headerBarPackStart titleBar logo
|
||||
|
||||
GTK.headerBarSetShowTitleButtons titleBar False
|
||||
GTK.headerBarSetDecorationLayout titleBar ( Just "icon:minimize,maximize,close" )
|
||||
|
||||
titleLabel <- GTK.labelNew ( Just "MetaBrush" )
|
||||
GTK.widgetSetHexpand titleLabel True
|
||||
widgetAddClasses titleLabel [ "text", "title", "plain" ]
|
||||
GTK.headerBarSetTitleWidget titleBar ( Just titleLabel )
|
||||
|
||||
--------
|
||||
-- Logo
|
||||
|
||||
widgetAddClass logo "logo"
|
||||
|
||||
logoArea <- GTK.drawingAreaNew
|
||||
GTK.boxAppend logo logoArea
|
||||
|
||||
GTK.widgetSetHexpand logoArea True
|
||||
GTK.widgetSetVexpand logoArea True
|
||||
|
||||
GTK.drawingAreaSetDrawFunc logoArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawLogo colours ) cairoContext
|
||||
|
||||
GTK.widgetQueueDraw logoArea
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Main viewport
|
||||
|
||||
viewport@( Viewport {..} ) <- createViewport viewportGrid
|
||||
|
||||
-----------------
|
||||
-- Viewport rendering
|
||||
|
||||
-- Update the document render data in a separate thread.
|
||||
_ <- forkIO $ forever do
|
||||
getRenderDoc <- STM.atomically do
|
||||
needsRecomputation <- STM.readTVar recomputeStrokesTVar
|
||||
case needsRecomputation of
|
||||
False -> STM.retry
|
||||
True -> do
|
||||
mbDocNow <- fmap present <$> activeDocument variables
|
||||
case mbDocNow of
|
||||
Nothing -> pure ( pure . const $ blankRender colours )
|
||||
Just doc -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
mbMousePos <- STM.readTVar mousePosTVar
|
||||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
mbPartialPath <- STM.readTVar partialPathTVar
|
||||
mode <- STM.readTVar modeTVar
|
||||
showGuides <- STM.readTVar showGuidesTVar
|
||||
debug <- STM.readTVar debugTVar
|
||||
fitParameters <- STM.readTVar fitParametersTVar
|
||||
STM.writeTVar recomputeStrokesTVar False
|
||||
let
|
||||
addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
|
||||
addRulers newRender viewportSize = do
|
||||
newRender viewportSize
|
||||
renderRuler
|
||||
colours viewportSize ViewportOrigin viewportSize
|
||||
mbMousePos mbHoldAction showGuides
|
||||
doc
|
||||
pure
|
||||
( addRulers <$> getDocumentRender
|
||||
colours fitParameters mode debug
|
||||
modifiers mbMousePos mbHoldAction mbPartialPath
|
||||
doc
|
||||
)
|
||||
renderDoc <- stToIO getRenderDoc
|
||||
STM.atomically do
|
||||
STM.writeTVar documentRenderTVar renderDoc
|
||||
void do
|
||||
GLib.idleAdd GLib.PRIORITY_HIGH_IDLE do
|
||||
for_
|
||||
[ viewportDrawingArea
|
||||
, rulerCornerDrawingArea
|
||||
, topRulerDrawingArea
|
||||
, leftRulerDrawingArea
|
||||
]
|
||||
GTK.widgetQueueDraw
|
||||
pure False
|
||||
|
||||
-- Render the document using the latest available draw data.
|
||||
GTK.drawingAreaSetDrawFunc viewportDrawingArea $ Just \ _ cairoContext _ _ -> void $ do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
-- Get the Cairo instructions for rendering the current document
|
||||
mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
|
||||
render <- case mbDoc of
|
||||
Nothing -> pure ( blankRender colours )
|
||||
Just _ -> STM.atomically do
|
||||
render <- STM.readTVar documentRenderTVar
|
||||
pure ( render ( viewportWidth, viewportHeight ) )
|
||||
Cairo.renderWithContext render cairoContext
|
||||
|
||||
for_
|
||||
[ ( rulerCornerDrawingArea , RulerCorner )
|
||||
, ( topRulerDrawingArea , TopRuler )
|
||||
, ( leftRulerDrawingArea , LeftRuler )
|
||||
]
|
||||
( \ ( rulerDrawingArea, ruler ) ->
|
||||
GTK.drawingAreaSetDrawFunc rulerDrawingArea $ Just \ _ cairoContext _ _ -> void do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
width <- GTK.widgetGetAllocatedWidth rulerDrawingArea
|
||||
height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
|
||||
mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
|
||||
mbMousePos <- STM.readTVar mousePosTVar
|
||||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
showGuides <- STM.readTVar showGuidesTVar
|
||||
pure do
|
||||
renderRuler
|
||||
colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
|
||||
mbMousePos mbHoldAction showGuides
|
||||
doc
|
||||
for_ mbRender \ render ->
|
||||
Cairo.renderWithContext render cairoContext
|
||||
)
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Tool bar
|
||||
|
||||
_ <- createToolBar variables colours toolBar
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Info bar
|
||||
|
||||
infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
|
||||
|
||||
menuActions <- createMenuActions
|
||||
|
||||
rec
|
||||
|
||||
---------------------------------------------------------
|
||||
-- File bar
|
||||
|
||||
fileBar@( FileBar { fileBarBox } ) <-
|
||||
createFileBar
|
||||
colours variables
|
||||
application window windowKeys titleBar titleLabel viewport infoBar
|
||||
menuBar menuActions
|
||||
|
||||
let
|
||||
uiElements :: UIElements
|
||||
uiElements = UIElements {..}
|
||||
|
||||
------------
|
||||
-- Menu bar
|
||||
|
||||
menuBar <- createMenuBar uiElements variables colours
|
||||
|
||||
GTK.boxAppend mainView fileBarBox
|
||||
GTK.boxAppend mainView viewportGrid
|
||||
GTK.boxAppend mainView infoBarArea
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels
|
||||
|
||||
createPanelBar panelBox
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
handleEvents uiElements variables
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Finishing up
|
||||
|
||||
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
|
||||
updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
|
||||
|
||||
GTK.widgetShow window
|
||||
|
||||
GTK.widgetSetCanFocus viewportDrawingArea True
|
||||
GTK.widgetSetFocusOnClick viewportDrawingArea True
|
||||
GTK.widgetSetFocusable viewportDrawingArea True
|
||||
_ <- GTK.widgetGrabFocus viewportDrawingArea
|
||||
|
||||
-- need to add the controllers after the callbacks have been registered
|
||||
GTK.widgetAddController window windowKeys
|
||||
GTK.widgetAddController viewportDrawingArea ( viewportMotionController viewportEventControllers )
|
||||
GTK.widgetAddController viewportDrawingArea ( viewportScrollController viewportEventControllers )
|
||||
GTK.widgetAddController viewportDrawingArea ( viewportClicksController viewportEventControllers )
|
||||
GTK.widgetAddController rulerCornerDrawingArea ( viewportMotionController rulerCornerEventControllers )
|
||||
GTK.widgetAddController rulerCornerDrawingArea ( viewportScrollController rulerCornerEventControllers )
|
||||
GTK.widgetAddController rulerCornerDrawingArea ( viewportClicksController rulerCornerEventControllers )
|
||||
GTK.widgetAddController leftRulerDrawingArea ( viewportMotionController leftRulerEventControllers )
|
||||
GTK.widgetAddController leftRulerDrawingArea ( viewportScrollController leftRulerEventControllers )
|
||||
GTK.widgetAddController leftRulerDrawingArea ( viewportClicksController leftRulerEventControllers )
|
||||
GTK.widgetAddController topRulerDrawingArea ( viewportMotionController topRulerEventControllers )
|
||||
GTK.widgetAddController topRulerDrawingArea ( viewportScrollController topRulerEventControllers )
|
||||
GTK.widgetAddController topRulerDrawingArea ( viewportClicksController topRulerEventControllers )
|
||||
|
|
@ -1,13 +1,13 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
|
||||
module MetaBrush.Asset.Colours
|
||||
( ColourRecord(..), ColourType
|
||||
( ColourRecord(..)
|
||||
, Colours, getColours
|
||||
)
|
||||
where
|
||||
|
|
@ -42,61 +42,53 @@ data ColourRecord a
|
|||
}
|
||||
deriving stock ( Show, Functor, Foldable, Traversable )
|
||||
|
||||
data ColourType
|
||||
= Colour
|
||||
| BackgroundColour
|
||||
deriving stock Show
|
||||
|
||||
data ColourName
|
||||
= ColourName
|
||||
{ colourName :: !Text
|
||||
, colourType :: !ColourType
|
||||
, stateFlags :: ![ GTK.StateFlags ]
|
||||
}
|
||||
newtype ColourName
|
||||
= ColourName { colourName :: Text }
|
||||
deriving stock Show
|
||||
|
||||
colourNames :: ColourRecord ColourName
|
||||
colourNames = Colours
|
||||
{ bg = ColourName "bg" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, active = ColourName "active" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, close = ColourName "close" Colour [ GTK.StateFlagsNormal ]
|
||||
, highlight = ColourName "highlight" Colour [ GTK.StateFlagsNormal ]
|
||||
, cursor = ColourName "cursor" Colour [ GTK.StateFlagsNormal ]
|
||||
, cursorOutline = ColourName "cursorStroke" Colour [ GTK.StateFlagsNormal ]
|
||||
, cursorIndicator = ColourName "cursorIndicator" Colour [ GTK.StateFlagsNormal ]
|
||||
, plain = ColourName "plain" Colour [ GTK.StateFlagsNormal ]
|
||||
, base = ColourName "base" Colour [ GTK.StateFlagsNormal ]
|
||||
, splash = ColourName "splash" Colour [ GTK.StateFlagsNormal ]
|
||||
, pathPoint = ColourName "pathPoint" Colour [ GTK.StateFlagsNormal ]
|
||||
, pathPointOutline = ColourName "pathPointStroke" Colour [ GTK.StateFlagsNormal ]
|
||||
, controlPoint = ColourName "controlPoint" Colour [ GTK.StateFlagsNormal ]
|
||||
, controlPointOutline = ColourName "controlPointStroke" Colour [ GTK.StateFlagsNormal ]
|
||||
, path = ColourName "path" Colour [ GTK.StateFlagsNormal ]
|
||||
, brush = ColourName "brush" Colour [ GTK.StateFlagsNormal ]
|
||||
, brushStroke = ColourName "brushStroke" Colour [ GTK.StateFlagsNormal ]
|
||||
, brushCenter = ColourName "brushCenter" Colour [ GTK.StateFlagsNormal ]
|
||||
, pointHover = ColourName "pointHover" Colour [ GTK.StateFlagsNormal ]
|
||||
, pointSelected = ColourName "pointSelected" Colour [ GTK.StateFlagsNormal ]
|
||||
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, rulerBg = ColourName "ruler" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, rulerTick = ColourName "rulerTick" Colour [ GTK.StateFlagsNormal ]
|
||||
, guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ]
|
||||
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
|
||||
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
|
||||
, selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ]
|
||||
, selectedOutline = ColourName "selectedOutline" Colour [ GTK.StateFlagsNormal ]
|
||||
{ bg = ColourName "bg"
|
||||
, active = ColourName "active"
|
||||
, close = ColourName "close"
|
||||
, highlight = ColourName "highlight"
|
||||
, cursor = ColourName "cursor"
|
||||
, cursorOutline = ColourName "cursorStroke"
|
||||
, cursorIndicator = ColourName "cursorIndicator"
|
||||
, plain = ColourName "plain"
|
||||
, base = ColourName "base"
|
||||
, splash = ColourName "splash"
|
||||
, pathPoint = ColourName "pathPoint"
|
||||
, pathPointOutline = ColourName "pathPointStroke"
|
||||
, controlPoint = ColourName "controlPoint"
|
||||
, controlPointOutline = ColourName "controlPointStroke"
|
||||
, path = ColourName "path"
|
||||
, brush = ColourName "brush"
|
||||
, brushStroke = ColourName "brushStroke"
|
||||
, brushCenter = ColourName "brushCenter"
|
||||
, pointHover = ColourName "pointHover"
|
||||
, pointSelected = ColourName "pointSelected"
|
||||
, viewport = ColourName "viewport"
|
||||
, viewportScrollbar = ColourName "viewportScrollbar"
|
||||
, tabScrollbar = ColourName "tabScrollbar"
|
||||
, rulerBg = ColourName "ruler"
|
||||
, rulerTick = ColourName "rulerTick"
|
||||
, guide = ColourName "guide"
|
||||
, magnifier = ColourName "magnifier"
|
||||
, glass = ColourName "glass"
|
||||
, selected = ColourName "selected"
|
||||
, selectedOutline = ColourName "selectedOutline"
|
||||
}
|
||||
|
||||
type Colours = ColourRecord GDK.RGBA
|
||||
|
||||
getColours :: GTK.WidgetPath -> IO Colours
|
||||
getColours windowWidgetPath =
|
||||
for colourNames \ ( ColourName {..} ) -> do
|
||||
style <- GTK.styleContextNew
|
||||
GTK.styleContextSetPath style windowWidgetPath
|
||||
getColours
|
||||
:: ( GTK.IsStyleProvider styleProvider )
|
||||
=> styleProvider -> IO Colours
|
||||
getColours provider =
|
||||
for colourNames \ ( ColourName { colourName } ) -> do
|
||||
widget <- GTK.fixedNew
|
||||
style <- GTK.widgetGetStyleContext widget
|
||||
GTK.styleContextAddProvider style provider ( fromIntegral GTK.STYLE_PROVIDER_PRIORITY_USER )
|
||||
GTK.styleContextAddClass style colourName
|
||||
case colourType of
|
||||
BackgroundColour -> GTK.styleContextGetBackgroundColor style stateFlags
|
||||
Colour -> GTK.styleContextGetColor style stateFlags
|
||||
GTK.styleContextGetColor style
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
module MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, LR(..), Modifier(..), modifierKey, modifierType
|
||||
, LR(..), Modifier(..), modifierKey
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
)
|
||||
where
|
||||
|
|
@ -24,9 +24,12 @@ import Data.Map.Strict
|
|||
import qualified GI.Cairo.Render as Cairo
|
||||
( Render )
|
||||
|
||||
-- gi-gtk
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
|
|
@ -43,6 +46,8 @@ import Math.Bezier.Cubic.Fit
|
|||
( FitParameters )
|
||||
import Math.Vector2D
|
||||
( Point2D )
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
( ActionName )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Brush
|
||||
|
|
@ -54,11 +59,9 @@ import MetaBrush.Document.History
|
|||
import MetaBrush.Document.Selection
|
||||
( DragMoveSelect )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( FileBar )
|
||||
( FileBar, FileBarTab )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.Menu
|
||||
( Menu, ResourceType(Object) )
|
||||
import {-# SOURCE #-} MetaBrush.UI.ToolBar
|
||||
( Tool, Mode )
|
||||
import MetaBrush.UI.Viewport
|
||||
|
|
@ -70,35 +73,38 @@ import MetaBrush.Unique
|
|||
|
||||
data UIElements
|
||||
= UIElements
|
||||
{ window :: !GTK.Window
|
||||
, title :: !GTK.Label
|
||||
, titleBar :: !GTK.Box
|
||||
, fileBar :: !FileBar
|
||||
, viewport :: !Viewport
|
||||
, infoBar :: !InfoBar
|
||||
, menu :: Menu Object -- needs to be lazy for "recursive do"
|
||||
, colours :: !Colours
|
||||
{ application :: !GTK.Application
|
||||
, window :: !GTK.ApplicationWindow
|
||||
, windowKeys :: !GTK.EventControllerKey
|
||||
, titleBar :: !GTK.HeaderBar
|
||||
, titleLabel :: !GTK.Label
|
||||
, fileBar :: !FileBar
|
||||
, viewport :: !Viewport
|
||||
, infoBar :: !InfoBar
|
||||
, menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
|
||||
, menuActions :: !( HashMap ActionName GIO.SimpleAction )
|
||||
, colours :: !Colours
|
||||
}
|
||||
|
||||
data Variables
|
||||
= Variables
|
||||
{ uniqueSupply :: !UniqueSupply
|
||||
, recomputeStrokesTVar :: !( STM.TVar Bool )
|
||||
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
|
||||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||||
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
|
||||
, brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) )
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
|
||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||
, toolTVar :: !( STM.TVar Tool )
|
||||
, modeTVar :: !( STM.TVar Mode )
|
||||
, debugTVar :: !( STM.TVar Bool )
|
||||
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
|
||||
, fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) )
|
||||
, showGuidesTVar :: !( STM.TVar Bool )
|
||||
, maxHistorySizeTVar :: !( STM.TVar Int )
|
||||
, fitParametersTVar :: !( STM.TVar FitParameters )
|
||||
, recomputeStrokesTVar :: !( STM.TVar Bool )
|
||||
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
|
||||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||||
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
|
||||
, brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) )
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
|
||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||
, toolTVar :: !( STM.TVar Tool )
|
||||
, modeTVar :: !( STM.TVar Mode )
|
||||
, debugTVar :: !( STM.TVar Bool )
|
||||
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
|
||||
, fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) )
|
||||
, showGuidesTVar :: !( STM.TVar Bool )
|
||||
, maxHistorySizeTVar :: !( STM.TVar Int )
|
||||
, fitParametersTVar :: !( STM.TVar FitParameters )
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -113,19 +119,14 @@ data Modifier
|
|||
deriving stock ( Show, Eq, Ord )
|
||||
|
||||
modifierKey :: Word32 -> Maybe Modifier
|
||||
modifierKey GDK.KEY_Control_L = Just ( Control L )
|
||||
modifierKey GDK.KEY_Control_R = Just ( Control R )
|
||||
modifierKey GDK.KEY_Shift_L = Just ( Shift L )
|
||||
modifierKey GDK.KEY_Shift_R = Just ( Shift R )
|
||||
modifierKey GDK.KEY_Alt_L = Just ( Alt L )
|
||||
modifierKey GDK.KEY_Alt_R = Just ( Alt R )
|
||||
modifierKey _ = Nothing
|
||||
|
||||
modifierType :: Modifier -> GDK.ModifierType
|
||||
modifierType ( Control _ ) = GDK.ModifierTypeControlMask
|
||||
modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask
|
||||
modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask
|
||||
|
||||
modifierKey n = case fromIntegral n of
|
||||
GDK.KEY_Control_L -> Just ( Control L )
|
||||
GDK.KEY_Control_R -> Just ( Control R )
|
||||
GDK.KEY_Shift_L -> Just ( Shift L )
|
||||
GDK.KEY_Shift_R -> Just ( Shift R )
|
||||
GDK.KEY_Alt_L -> Just ( Alt L )
|
||||
GDK.KEY_Alt_R -> Just ( Alt R )
|
||||
_ -> Nothing
|
||||
|
||||
data GuideAction
|
||||
= CreateGuide !Ruler
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
|
@ -38,6 +39,9 @@ import qualified Data.Map.Strict as Map
|
|||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
|
|
@ -65,22 +69,25 @@ import Control.Monad.Trans.Class
|
|||
import Control.Monad.Trans.Maybe
|
||||
( MaybeT(..) )
|
||||
|
||||
-- unordered-containers
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
( lookup )
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
( ActionName(..) )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..) )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory(..)
|
||||
( DocumentHistory(..), atStart, atEnd
|
||||
, newFutureStep, affirmPresent
|
||||
, atStart, atEnd
|
||||
)
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
( removeFileTab )
|
||||
( FileBarTab(..), removeFileTab )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( updateInfoBar )
|
||||
import MetaBrush.UI.Menu
|
||||
( ResourceType(..), MenuItem(..), Menu(..), EditMenu(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Util
|
||||
|
|
@ -145,7 +152,7 @@ instance DocumentModification DocModification where
|
|||
--
|
||||
-- Does nothing if no document is currently active.
|
||||
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
|
||||
modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f = do
|
||||
modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables {..} ) f = do
|
||||
mbAction <- STM.atomically . runMaybeT $ do
|
||||
unique <- MaybeT ( STM.readTVar activeDocumentTVar )
|
||||
oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar )
|
||||
|
|
@ -185,25 +192,21 @@ modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f
|
|||
uiUpdateAction <- updateUIAction uiElts vars
|
||||
pure $ Ap do
|
||||
uiUpdateAction
|
||||
GTK.widgetSetSensitive undoMenuItem True
|
||||
GTK.widgetSetSensitive redoMenuItem False
|
||||
for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
|
||||
for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
pure
|
||||
do
|
||||
forOf_ docFold modif \ mbNewDoc -> do
|
||||
case mbNewDoc of
|
||||
CloseDocument -> removeFileTab vars ( documentUnique oldDoc )
|
||||
CloseDocument -> removeFileTab uiElts vars ( documentUnique oldDoc )
|
||||
_ -> pure ()
|
||||
uiUpdateAction
|
||||
sequenceAOf_ actionFold modif
|
||||
sequenceA_ mbAction
|
||||
where
|
||||
undoMenuItem, redoMenuItem :: GTK.MenuItem
|
||||
undoMenuItem = menuItem $ undo $ menuItemSubmenu $ edit menu
|
||||
redoMenuItem = menuItem $ redo $ menuItemSubmenu $ edit menu
|
||||
|
||||
|
||||
updateUIAction :: UIElements -> Variables -> STM ( IO () )
|
||||
updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
|
||||
updateUIAction uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
|
||||
mbDocHist <- activeDocument vars
|
||||
let
|
||||
mbDoc :: Maybe Document
|
||||
|
|
@ -214,18 +217,18 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
|
|||
mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
|
||||
pure ( (,) <$> mbActiveTab <*> mbDoc )
|
||||
pure do
|
||||
updateTitle window title mbTitleText
|
||||
updateTitle window titleLabel mbTitleText
|
||||
updateInfoBar viewportDrawingArea infoBar vars mbDoc
|
||||
for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do
|
||||
GTK.buttonSetLabel activeTabLabel ( displayName activeDoc )
|
||||
GTK.widgetQueueDraw activeTab
|
||||
STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
|
||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetQueueDraw drawingArea
|
||||
for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, activeDoc ) -> do
|
||||
GTK.buttonSetLabel fileBarTabButton ( displayName activeDoc )
|
||||
GTK.widgetQueueDraw fileBarTab
|
||||
GTK.widgetQueueDraw fileBarTabCloseArea
|
||||
updateHistoryState uiElts mbDocHist
|
||||
STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
|
||||
|
||||
updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
|
||||
updateTitle window title mbTitleText = do
|
||||
GTK.labelSetText title titleText
|
||||
updateTitle :: GTK.IsWindow window => window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
|
||||
updateTitle window titleLabel mbTitleText = do
|
||||
GTK.labelSetText titleLabel titleText
|
||||
GTK.setWindowTitle window titleText
|
||||
where
|
||||
titleText :: Text
|
||||
|
|
@ -241,18 +244,12 @@ updateHistoryState :: UIElements -> Maybe DocumentHistory -> IO ()
|
|||
updateHistoryState ( UIElements {..} ) mbHist =
|
||||
case mbHist of
|
||||
Nothing -> do
|
||||
GTK.widgetSetSensitive undoMenuItem False
|
||||
GTK.widgetSetSensitive redoMenuItem False
|
||||
for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
Just hist -> do
|
||||
if atStart hist
|
||||
then GTK.widgetSetSensitive undoMenuItem False
|
||||
else GTK.widgetSetSensitive undoMenuItem True
|
||||
then for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
else for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
|
||||
if atEnd hist
|
||||
then GTK.widgetSetSensitive redoMenuItem False
|
||||
else GTK.widgetSetSensitive redoMenuItem True
|
||||
where
|
||||
editMenu :: EditMenu Object
|
||||
editMenu = menuItemSubmenu ( edit menu )
|
||||
undoMenuItem, redoMenuItem :: GTK.MenuItem
|
||||
undoMenuItem = menuItem $ undo $ editMenu
|
||||
redoMenuItem = menuItem $ redo $ editMenu
|
||||
then for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
|
||||
else for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
|
||||
|
|
|
|||
|
|
@ -12,6 +12,10 @@ import Control.Monad
|
|||
( void )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
|
@ -19,6 +23,10 @@ import qualified GI.Gdk as GDK
|
|||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( readTVarIO )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
|
|
@ -32,7 +40,7 @@ import MetaBrush.Action
|
|||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..) )
|
||||
( Viewport(..), ViewportEventControllers(..), Ruler(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -40,72 +48,74 @@ handleEvents :: UIElements -> Variables -> IO ()
|
|||
handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
|
||||
|
||||
-- Mouse events
|
||||
afterWidgetMouseEvent viewportDrawingArea ViewportOrigin
|
||||
afterWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner )
|
||||
afterWidgetMouseEvent leftRulerDrawingArea ( RulerOrigin LeftRuler )
|
||||
afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler )
|
||||
afterWidgetMouseEvent viewportEventControllers ViewportOrigin
|
||||
afterWidgetMouseEvent rulerCornerEventControllers ( RulerOrigin RulerCorner )
|
||||
afterWidgetMouseEvent leftRulerEventControllers ( RulerOrigin LeftRuler )
|
||||
afterWidgetMouseEvent topRulerEventControllers ( RulerOrigin TopRuler )
|
||||
|
||||
-- Keyboard events
|
||||
void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
|
||||
void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
|
||||
void $ GTK.onEventControllerKeyKeyPressed windowKeys
|
||||
( handleKeyboardPressEvent elts vars )
|
||||
void $ GTK.onEventControllerKeyKeyReleased windowKeys
|
||||
( handleKeyboardReleaseEvent elts vars )
|
||||
|
||||
-- Window quit
|
||||
void $ GTK.onWidgetDestroy window ( quitEverything window )
|
||||
void $ GTK.onApplicationQueryEnd application ( quitEverything application window )
|
||||
|
||||
where
|
||||
afterWidgetMouseEvent :: GTK.DrawingArea -> ActionOrigin -> IO ()
|
||||
afterWidgetMouseEvent drawingArea eventOrigin = do
|
||||
void $ GTK.afterWidgetMotionNotifyEvent drawingArea ( handleMotionEvent elts vars eventOrigin )
|
||||
void $ GTK.afterWidgetScrollEvent drawingArea ( handleScrollEvent elts vars eventOrigin )
|
||||
void $ GTK.afterWidgetButtonPressEvent drawingArea ( handleMouseButtonEvent elts vars eventOrigin )
|
||||
void $ GTK.afterWidgetButtonReleaseEvent drawingArea ( handleMouseButtonRelease elts vars eventOrigin )
|
||||
afterWidgetMouseEvent :: ViewportEventControllers -> ActionOrigin -> IO ()
|
||||
afterWidgetMouseEvent ( ViewportEventControllers {..}) eventOrigin = do
|
||||
void $ GTK.afterEventControllerMotionMotion viewportMotionController
|
||||
( handleMotionEvent elts vars eventOrigin )
|
||||
void $ GTK.afterEventControllerScrollScroll viewportScrollController
|
||||
( handleScrollEvent elts vars )
|
||||
void $ GTK.afterGestureClickPressed viewportClicksController
|
||||
( handleMouseButtonEvent elts vars eventOrigin viewportClicksController )
|
||||
void $ GTK.afterGestureClickReleased viewportClicksController
|
||||
( handleMouseButtonRelease elts vars eventOrigin viewportClicksController )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Mouse events.
|
||||
|
||||
handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool
|
||||
handleMotionEvent elts vars eventOrigin eventMotion = do
|
||||
x <- GDK.getEventMotionX eventMotion
|
||||
y <- GDK.getEventMotionY eventMotion
|
||||
handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () )
|
||||
handleMotionEvent elts vars eventOrigin x y = do
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( MouseMove mousePos )
|
||||
pure True
|
||||
|
||||
handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool
|
||||
handleScrollEvent elts vars eventOrigin scrollEvent = do
|
||||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||||
x <- GDK.getEventScrollX scrollEvent
|
||||
y <- GDK.getEventScrollY scrollEvent
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( Scroll mousePos ( Vector2D dx dy ) )
|
||||
handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool )
|
||||
handleScrollEvent elts vars dx dy = do
|
||||
mbMousePos <- STM.readTVarIO ( mousePosTVar vars )
|
||||
handleAction elts vars ( Scroll mbMousePos ( Vector2D dx dy ) )
|
||||
pure False
|
||||
|
||||
handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
|
||||
ty <- GDK.getEventButtonType mouseClickEvent
|
||||
handleMouseButtonEvent
|
||||
:: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick
|
||||
-> ( Int32 -> Double -> Double -> IO () )
|
||||
handleMouseButtonEvent elts@( UIElements{ viewport = Viewport {..} } ) vars eventOrigin gestureClick nbClicks x y = do
|
||||
let
|
||||
mbClick :: Maybe MouseClickType
|
||||
mbClick = case ty of
|
||||
GDK.EventTypeButtonPress -> Just SingleClick
|
||||
GDK.EventType2buttonPress -> Just DoubleClick
|
||||
_ -> Nothing
|
||||
mbClick
|
||||
| nbClicks >= 2
|
||||
= Just DoubleClick
|
||||
| nbClicks == 1
|
||||
= Just SingleClick
|
||||
| otherwise
|
||||
= Nothing
|
||||
for_ mbClick \ click -> do
|
||||
button <- GDK.getEventButtonButton mouseClickEvent
|
||||
x <- GDK.getEventButtonX mouseClickEvent
|
||||
y <- GDK.getEventButtonY mouseClickEvent
|
||||
_ <- GTK.widgetGrabFocus viewportDrawingArea
|
||||
button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
|
||||
-- ^^^^^ use button number 1 if no button number is reported (button == 0)
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( MouseClick eventOrigin click button mousePos )
|
||||
pure False
|
||||
|
||||
handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
|
||||
button <- GDK.getEventButtonButton mouseReleaseEvent
|
||||
x <- GDK.getEventButtonX mouseReleaseEvent
|
||||
y <- GDK.getEventButtonY mouseReleaseEvent
|
||||
handleMouseButtonRelease
|
||||
:: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick
|
||||
-> ( Int32 -> Double -> Double -> IO () )
|
||||
handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do
|
||||
button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
|
||||
-- ^^^^^ same as above
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( MouseRelease button mousePos )
|
||||
pure False
|
||||
|
||||
adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
|
||||
adjustMousePosition _ ViewportOrigin pt = pure pt
|
||||
|
|
@ -125,14 +135,16 @@ adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) =
|
|||
--------------------------------------------------------------------------------
|
||||
-- Keyboard events.
|
||||
|
||||
handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardPressEvent elts vars evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
handleAction elts vars ( KeyboardPress keyCode )
|
||||
handleKeyboardPressEvent
|
||||
:: UIElements -> Variables
|
||||
-> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO Bool )
|
||||
handleKeyboardPressEvent elts vars keyVal _ _ = do
|
||||
handleAction elts vars ( KeyboardPress keyVal )
|
||||
pure False -- allow the default handler to run
|
||||
|
||||
handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardReleaseEvent elts vars evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
handleAction elts vars ( KeyboardRelease keyCode )
|
||||
pure False -- allow the default handler to run
|
||||
|
||||
handleKeyboardReleaseEvent
|
||||
:: UIElements -> Variables
|
||||
-> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO () )
|
||||
handleKeyboardReleaseEvent elts vars keyVal _ _ =
|
||||
handleAction elts vars ( KeyboardRelease keyVal )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.FileBar
|
||||
( FileBar(..)
|
||||
( FileBar(..), FileBarTab(..)
|
||||
, createFileBar, newFileTab, removeFileTab
|
||||
, TabLocation(..)
|
||||
)
|
||||
|
|
@ -15,11 +15,9 @@ module MetaBrush.UI.FileBar
|
|||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( join, unless, void )
|
||||
( join, void )
|
||||
import Data.Foldable
|
||||
( for_, sequenceA_ )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
|
||||
|
|
@ -31,13 +29,12 @@ import qualified Data.Map.Strict as Map
|
|||
import qualified GI.Cairo.Render.Connector as Cairo
|
||||
( renderWithContext )
|
||||
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- haskell-gi-base
|
||||
import qualified Data.GI.Base.GValue as GI
|
||||
import qualified Data.GI.Base.GType as GI
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
|
|
@ -48,9 +45,13 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
|
||||
-- unordered-containers
|
||||
import Data.HashMap.Lazy
|
||||
( HashMap )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Action
|
||||
( SwitchTo(..), Close(..), handleAction )
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
( ActionName, SwitchFromTo(..), Close(..), handleAction )
|
||||
import MetaBrush.Asset.CloseTabButton
|
||||
( drawCloseTabButton )
|
||||
import MetaBrush.Asset.Colours
|
||||
|
|
@ -67,16 +68,12 @@ import MetaBrush.Document.Update
|
|||
( updateUIAction )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.Menu
|
||||
( Menu, ResourceType(Object) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique, freshUnique, uniqueText )
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses
|
||||
, Exists(..)
|
||||
)
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -84,7 +81,14 @@ data FileBar
|
|||
= FileBar
|
||||
{ fileBarBox :: !GTK.Box
|
||||
, fileTabsBox :: !GTK.Box
|
||||
, fileBarPhantomRadioButton :: !GTK.RadioButton
|
||||
, fileBarPhantomToggleButton :: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
data FileBarTab
|
||||
= FileBarTab
|
||||
{ fileBarTab :: !GTK.Box
|
||||
, fileBarTabButton :: !GTK.ToggleButton
|
||||
, fileBarTabCloseArea :: !GTK.DrawingArea
|
||||
}
|
||||
|
||||
data TabLocation
|
||||
|
|
@ -93,14 +97,12 @@ data TabLocation
|
|||
deriving stock Show
|
||||
|
||||
newFileTab
|
||||
:: Bool
|
||||
-> UIElements
|
||||
:: UIElements
|
||||
-> Variables
|
||||
-> Maybe DocumentHistory
|
||||
-> TabLocation
|
||||
-> IO ()
|
||||
newFileTab
|
||||
initialStage
|
||||
uiElts@( UIElements { fileBar = FileBar {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
mbDocHist
|
||||
|
|
@ -116,18 +118,19 @@ newFileTab
|
|||
pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
|
||||
|
||||
let
|
||||
newUnique :: Unique
|
||||
newUnique = documentUnique ( present newDocHist )
|
||||
thisTabDocUnique :: Unique
|
||||
thisTabDocUnique = documentUnique ( present newDocHist )
|
||||
|
||||
-- TODO: make the file tab an EditableLabel
|
||||
-- File tab elements.
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName $ present newDocHist )
|
||||
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
|
||||
pgButton <- GTK.toggleButtonNewWithLabel ( displayName $ present newDocHist )
|
||||
GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton )
|
||||
closeFileButton <- GTK.buttonNew
|
||||
closeFileArea <- GTK.drawingAreaNew
|
||||
GTK.containerAdd closeFileButton closeFileArea
|
||||
GTK.buttonSetChild closeFileButton ( Just closeFileArea )
|
||||
|
||||
void $ GTK.onWidgetDraw closeFileArea \ cairoContext -> do
|
||||
mbTabDoc <- fmap present . Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
|
||||
GTK.drawingAreaSetDrawFunc closeFileArea $ Just \ _ cairoContext _ _ -> void do
|
||||
mbTabDoc <- fmap present . Map.lookup thisTabDocUnique <$> STM.readTVarIO openDocumentsTVar
|
||||
let
|
||||
unsaved :: Bool
|
||||
unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc
|
||||
|
|
@ -137,104 +140,115 @@ newFileTab
|
|||
-- Create box for file tab elements.
|
||||
tab <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClasses tab [ "fileBarTab" ]
|
||||
GTK.boxPackStart fileTabsBox tab False False 0
|
||||
GTK.boxPackStart tab pgButton True True 0
|
||||
GTK.boxPackStart tab closeFileButton False False 0
|
||||
GTK.boxAppend tab pgButton
|
||||
GTK.boxAppend tab closeFileButton
|
||||
widgetAddClasses pgButton [ "fileBarTabButton" ]
|
||||
widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
|
||||
GTK.widgetShowAll tab
|
||||
|
||||
-- We've placed the new tab at the end. Now rearrange it if necessary.
|
||||
-- Place the new tab in the correct position within the file bar.
|
||||
case newTabLoc of
|
||||
LastTab -> pure ()
|
||||
LastTab ->
|
||||
GTK.boxAppend fileTabsBox tab
|
||||
AfterCurrentTab -> do
|
||||
mbActiveTab <- fmap join $ STM.atomically do
|
||||
mbUnique <- STM.readTVar activeDocumentTVar
|
||||
for mbUnique \ docUnique -> do
|
||||
Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
for_ mbActiveTab \ ( activeTab, _ ) -> do
|
||||
old_gValue <- GI.newGValue GI.gtypeInt
|
||||
GTK.containerChildGetProperty fileTabsBox activeTab "position" old_gValue
|
||||
new_gValue <- GI.toGValue @Int32 =<< ( +1 ) <$> GI.fromGValue @Int32 old_gValue
|
||||
GTK.containerChildSetProperty fileTabsBox tab "position" new_gValue
|
||||
|
||||
-- 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
|
||||
case mbActiveTab of
|
||||
Just ( FileBarTab { fileBarTab = activeTab } )
|
||||
-> GTK.boxInsertChildAfter fileTabsBox tab ( Just activeTab )
|
||||
_ -> GTK.boxAppend fileTabsBox tab
|
||||
|
||||
let
|
||||
fileBarTab :: FileBarTab
|
||||
fileBarTab =
|
||||
FileBarTab
|
||||
{ fileBarTab = tab
|
||||
, fileBarTabButton = pgButton
|
||||
, fileBarTabCloseArea = closeFileArea
|
||||
}
|
||||
-- Update the state: switch to this new document.
|
||||
uiUpdateAction <- STM.atomically do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDocHist )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique ( tab, pgButton ) )
|
||||
-- don't update UI if we are just creating file tabs for the first time
|
||||
-- (we don't have access to the full menu at that point, so this would otherwise loop)
|
||||
if initialStage
|
||||
then pure ( pure () )
|
||||
else do
|
||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
updateUIAction uiElts vars
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique newDocHist )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab )
|
||||
STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
|
||||
updateUIAction uiElts vars
|
||||
uiUpdateAction
|
||||
|
||||
void $ GTK.onButtonClicked pgButton do
|
||||
isActive <- GTK.toggleButtonGetActive pgButton
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
if isActive
|
||||
void $ GTK.afterToggleButtonToggled pgButton do
|
||||
nowActive <- GTK.toggleButtonGetActive pgButton
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
mbPrevActiveDocUnique <- STM.readTVarIO activeDocumentTVar
|
||||
if nowActive
|
||||
then do
|
||||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
|
||||
handleAction uiElts vars ( SwitchTo newUnique )
|
||||
-- If changing tabs, switch document.
|
||||
-- This will untoggle the previously active tab
|
||||
-- ('onToggleButtonToggled' will run this handler).
|
||||
handleAction uiElts vars ( SwitchFromTo mbPrevActiveDocUnique thisTabDocUnique )
|
||||
GTK.widgetSetStateFlags tab
|
||||
( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
|
||||
True
|
||||
else do
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||
GTK.widgetQueueDraw closeFileArea
|
||||
-- Otherwise, ensure the tab hasn't been toggled off on its own
|
||||
-- (clicking on an already selected tab shouldn't do anything, not untoggle the tab).
|
||||
mbNewActiveDocUnique <- STM.readTVarIO activeDocumentTVar
|
||||
case mbNewActiveDocUnique of
|
||||
-- Clicking on already selected document: don't allow the tab to be toggled off.
|
||||
Just unique | unique == thisTabDocUnique
|
||||
-> do
|
||||
GTK.toggleButtonSetActive pgButton True
|
||||
GTK.widgetSetStateFlags tab
|
||||
( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
|
||||
True
|
||||
-- Otherwise: leave it toggled off.
|
||||
_ -> GTK.widgetSetStateFlags tab
|
||||
( filter (/= GTK.StateFlagsActive) flags )
|
||||
True
|
||||
|
||||
GTK.toggleButtonSetActive pgButton False
|
||||
GTK.toggleButtonSetActive pgButton True
|
||||
|
||||
void $ GTK.onButtonClicked closeFileButton do
|
||||
GTK.widgetQueueDraw closeFileArea
|
||||
handleAction uiElts vars ( CloseThis newUnique )
|
||||
|
||||
-- Activate the button, unless we are creating buttons for the first time,
|
||||
-- in which case we shouldn't activate it as we don't have a menu yet,
|
||||
-- so we wouldn't be able to handle the associated action.
|
||||
unless initialStage ( GTK.toggleButtonSetActive pgButton True )
|
||||
handleAction uiElts vars ( CloseThis thisTabDocUnique )
|
||||
|
||||
-- | Create a file bar: tabs allowing selection of the active document.
|
||||
--
|
||||
-- Updates the active document when buttons are clicked.
|
||||
createFileBar
|
||||
:: Colours -> Variables
|
||||
-> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object
|
||||
-> GTK.Application -> GTK.ApplicationWindow -> GTK.EventControllerKey
|
||||
-> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
|
||||
-> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
|
||||
-> IO FileBar
|
||||
createFileBar
|
||||
colours
|
||||
vars@( Variables { openDocumentsTVar } )
|
||||
window titleBar title viewport infoBar menu
|
||||
application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
|
||||
= do
|
||||
|
||||
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
||||
fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClass fileBarBox "fileBar"
|
||||
|
||||
fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
|
||||
fileTabsScroll <- GTK.scrolledWindowNew
|
||||
GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
|
||||
GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True
|
||||
GTK.widgetSetHexpand fileTabsScroll True
|
||||
|
||||
newFileButton <- GTK.buttonNewWithLabel "+"
|
||||
widgetAddClasses newFileButton [ "newFileButton" ]
|
||||
|
||||
GTK.boxPackEnd fileBarBox newFileButton False False 0
|
||||
GTK.boxPackStart fileBarBox fileTabsScroll True True 0
|
||||
GTK.boxAppend fileBarBox fileTabsScroll
|
||||
GTK.boxAppend fileBarBox newFileButton
|
||||
GTK.widgetSetHalign newFileButton GTK.AlignEnd
|
||||
|
||||
fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
GTK.containerAdd fileTabsScroll fileTabsBox
|
||||
GTK.scrolledWindowSetChild fileTabsScroll ( Just 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 )
|
||||
-- Phantom toggle button for when no page is selected (e.g. no documents opened yet).
|
||||
fileBarPhantomToggleButton <- GTK.toggleButtonNew
|
||||
|
||||
let
|
||||
fileBar :: FileBar
|
||||
|
|
@ -244,13 +258,13 @@ createFileBar
|
|||
|
||||
documents <- STM.readTVarIO openDocumentsTVar
|
||||
for_ documents \ doc ->
|
||||
newFileTab True
|
||||
newFileTab
|
||||
uiElements vars
|
||||
( Just doc )
|
||||
LastTab
|
||||
|
||||
void $ GTK.onButtonClicked newFileButton do
|
||||
newFileTab False
|
||||
newFileTab
|
||||
uiElements vars
|
||||
Nothing
|
||||
LastTab
|
||||
|
|
@ -258,15 +272,18 @@ createFileBar
|
|||
pure fileBar
|
||||
|
||||
-- | Close a document: remove the corresponding file tab from the file bar.
|
||||
removeFileTab :: Variables -> Unique -> IO ()
|
||||
removeFileTab ( Variables {..} ) docUnique = do
|
||||
removeFileTab :: UIElements -> Variables -> Unique -> IO ()
|
||||
removeFileTab
|
||||
( UIElements { fileBar = FileBar { fileTabsBox } } )
|
||||
( Variables {..} )
|
||||
docUnique = do
|
||||
|
||||
cleanupAction <- STM.atomically do
|
||||
-- Remove the tab.
|
||||
mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
for mbTab \ ( tab, _ ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique )
|
||||
pure ( GTK.widgetDestroy tab )
|
||||
|
||||
sequenceA_ cleanupAction
|
||||
cleanupAction <- STM.atomically do
|
||||
-- Remove the tab.
|
||||
mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
|
||||
for mbTab \ ( FileBarTab { fileBarTab = tab } ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
|
||||
STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique )
|
||||
pure ( GTK.boxRemove fileTabsBox tab )
|
||||
|
||||
sequenceA_ cleanupAction
|
||||
|
|
|
|||
|
|
@ -1,9 +1,6 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module MetaBrush.UI.FileBar
|
||||
( FileBar(..)
|
||||
, createFileBar, newFileTab, removeFileTab
|
||||
, TabLocation(..)
|
||||
( FileBar(..), FileBarTab(..), TabLocation(..)
|
||||
, removeFileTab
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -11,18 +8,8 @@ module MetaBrush.UI.FileBar
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
( Variables, UIElements )
|
||||
import MetaBrush.Document.History
|
||||
( DocumentHistory )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import {-# SOURCE #-} MetaBrush.UI.Menu
|
||||
( Menu, ResourceType(Object) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -32,7 +19,14 @@ data FileBar
|
|||
= FileBar
|
||||
{ fileBarBox :: !GTK.Box
|
||||
, fileTabsBox :: !GTK.Box
|
||||
, fileBarPhantomRadioButton :: !GTK.RadioButton
|
||||
, fileBarPhantomToggleButton :: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
data FileBarTab
|
||||
= FileBarTab
|
||||
{ fileBarTab :: !GTK.Box
|
||||
, fileBarTabButton :: !GTK.ToggleButton
|
||||
, fileBarTabCloseArea :: !GTK.DrawingArea
|
||||
}
|
||||
|
||||
data TabLocation
|
||||
|
|
@ -41,15 +35,4 @@ data TabLocation
|
|||
|
||||
instance Show TabLocation
|
||||
|
||||
createFileBar
|
||||
:: Colours -> Variables
|
||||
-> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object
|
||||
-> IO FileBar
|
||||
|
||||
newFileTab
|
||||
:: Bool
|
||||
-> UIElements -> Variables
|
||||
-> Maybe DocumentHistory -> TabLocation
|
||||
-> IO ()
|
||||
|
||||
removeFileTab :: Variables -> Unique -> IO ()
|
||||
removeFileTab :: UIElements -> Variables -> Unique -> IO ()
|
||||
|
|
|
|||
|
|
@ -78,6 +78,7 @@ createInfoBar :: Colours -> IO InfoBar
|
|||
createInfoBar colours = do
|
||||
infoBarArea <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ]
|
||||
GTK.widgetSetHalign infoBarArea GTK.AlignEnd
|
||||
|
||||
zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
|
|
@ -85,7 +86,7 @@ createInfoBar colours = do
|
|||
botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
|
||||
for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do
|
||||
GTK.boxPackEnd infoBarArea box False False 0
|
||||
GTK.boxPrepend infoBarArea box
|
||||
widgetAddClass box "infoBarBox"
|
||||
|
||||
-------------
|
||||
|
|
@ -94,11 +95,11 @@ createInfoBar colours = do
|
|||
magnifierArea <- GTK.drawingAreaNew
|
||||
zoomText <- GTK.labelNew ( Just na )
|
||||
|
||||
GTK.boxPackStart zoomBox magnifierArea True True 0
|
||||
GTK.boxPackStart zoomBox zoomText True True 0
|
||||
GTK.boxAppend zoomBox magnifierArea
|
||||
GTK.boxAppend zoomBox zoomText
|
||||
|
||||
void $ GTK.onWidgetDraw magnifierArea \ ctx ->
|
||||
( `Cairo.renderWithContext` ctx ) $ do
|
||||
GTK.drawingAreaSetDrawFunc magnifierArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ ( `Cairo.renderWithContext` cairoContext ) do
|
||||
Cairo.scale 0.9 0.9
|
||||
Cairo.translate 14 10
|
||||
drawMagnifier colours
|
||||
|
|
@ -109,11 +110,11 @@ createInfoBar colours = do
|
|||
cursorPosArea <- GTK.drawingAreaNew
|
||||
cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
|
||||
|
||||
GTK.boxPackStart cursorPosBox cursorPosArea False False 0
|
||||
GTK.boxPackStart cursorPosBox cursorPosText False False 0
|
||||
GTK.boxAppend cursorPosBox cursorPosArea
|
||||
GTK.boxAppend cursorPosBox cursorPosText
|
||||
|
||||
void $ GTK.onWidgetDraw cursorPosArea \ ctx ->
|
||||
( `Cairo.renderWithContext` ctx ) $ do
|
||||
GTK.drawingAreaSetDrawFunc cursorPosArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ ( `Cairo.renderWithContext` cairoContext ) do
|
||||
Cairo.scale 0.75 0.75
|
||||
Cairo.translate 9.5 7
|
||||
drawCursorIcon colours
|
||||
|
|
@ -124,12 +125,11 @@ createInfoBar colours = do
|
|||
topLeftPosArea <- GTK.drawingAreaNew
|
||||
topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
|
||||
|
||||
GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0
|
||||
GTK.boxPackStart topLeftPosBox topLeftPosText False False 0
|
||||
GTK.boxAppend topLeftPosBox topLeftPosArea
|
||||
GTK.boxAppend topLeftPosBox topLeftPosText
|
||||
|
||||
void $ GTK.onWidgetDraw topLeftPosArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawTopLeftCornerRect colours )
|
||||
GTK.drawingAreaSetDrawFunc topLeftPosArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawTopLeftCornerRect colours ) cairoContext
|
||||
|
||||
-------------------------
|
||||
-- Bottom right position
|
||||
|
|
@ -137,11 +137,11 @@ createInfoBar colours = do
|
|||
botRightPosArea <- GTK.drawingAreaNew
|
||||
botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
|
||||
|
||||
GTK.boxPackStart botRightPosBox botRightPosArea False False 0
|
||||
GTK.boxPackStart botRightPosBox botRightPosText False False 0
|
||||
GTK.boxAppend botRightPosBox botRightPosArea
|
||||
GTK.boxAppend botRightPosBox botRightPosText
|
||||
|
||||
void $ GTK.onWidgetDraw botRightPosArea \ ctx ->
|
||||
( `Cairo.renderWithContext` ctx ) $ do
|
||||
GTK.drawingAreaSetDrawFunc botRightPosArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ ( `Cairo.renderWithContext` cairoContext ) do
|
||||
Cairo.scale -1 -1
|
||||
Cairo.translate -40 -40
|
||||
drawTopLeftCornerRect colours
|
||||
|
|
@ -195,4 +195,4 @@ fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFl
|
|||
replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
|
||||
|
||||
na :: IsString a => a
|
||||
na = " n/a"
|
||||
na = " n/a"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
module MetaBrush.UI.InfoBar
|
||||
( InfoBar(..), createInfoBar, updateInfoBar )
|
||||
( InfoBar(..), updateInfoBar )
|
||||
where
|
||||
|
||||
-- gi-gtk
|
||||
|
|
@ -22,6 +22,5 @@ data InfoBar
|
|||
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
|
||||
}
|
||||
|
||||
createInfoBar :: Colours -> IO InfoBar
|
||||
|
||||
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
|
||||
updateInfoBar
|
||||
:: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
|
||||
|
|
|
|||
|
|
@ -1,52 +1,29 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.Menu
|
||||
( newMenuBar
|
||||
, Menu(..)
|
||||
, FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..)
|
||||
, ResourceType(..)
|
||||
, MenuItem(..)
|
||||
, createMenuBar
|
||||
)
|
||||
where
|
||||
module MetaBrush.UI.Menu where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( void, unless )
|
||||
( void )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Kind
|
||||
( Type )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Constraints
|
||||
( HasConstraints(constraints) )
|
||||
( for_, traverse_ )
|
||||
|
||||
-- gi-cairo-connector
|
||||
import qualified GI.Cairo.Render.Connector as Cairo
|
||||
( renderWithContext )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
-- gi-gio
|
||||
import qualified GI.Gio as GIO
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
|
@ -54,22 +31,33 @@ import qualified GI.Gtk as GTK
|
|||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( unpack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO(liftIO) )
|
||||
( MonadIO(..) )
|
||||
|
||||
-- unordered-containers
|
||||
import Data.HashMap.Strict
|
||||
( HashMap )
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
( lookup, traverseWithKey )
|
||||
import Data.HashSet
|
||||
( HashSet )
|
||||
import qualified Data.HashSet as HashSet
|
||||
( fromList, toMap )
|
||||
|
||||
-- MetaBrush
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
import MetaBrush.Action
|
||||
hiding ( save, saveAs )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, LR(..), Modifier(..), modifierType
|
||||
)
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Asset.WindowIcons
|
||||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
import MetaBrush.UI.FileBar
|
||||
( TabLocation(..) )
|
||||
import MetaBrush.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
|
|
@ -77,289 +65,226 @@ import MetaBrush.Util
|
|||
--------------------------------------------------------------------------------
|
||||
-- Types for describing menu items.
|
||||
|
||||
data ResourceType
|
||||
= Description
|
||||
| Object
|
||||
data MenuItem where
|
||||
SubmenuDescription ::
|
||||
{ submenuLabel :: !( Maybe Text )
|
||||
, submenuItems :: ![ MenuItem ]
|
||||
} -> MenuItem
|
||||
MenuItemDescription :: HandleAction action =>
|
||||
{ menuItemLabel :: !Text
|
||||
, menuItemAction :: !( Maybe ActionName, action )
|
||||
, menuItemAccel :: !( Maybe Text )
|
||||
} -> MenuItem
|
||||
Section ::
|
||||
{ sectionName :: !( Maybe Text )
|
||||
, sectionItems :: [ MenuItem ]
|
||||
} -> MenuItem
|
||||
|
||||
data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
|
||||
data instance MenuItem action submenu Description
|
||||
= MenuItemDescription
|
||||
{ menuItemLabel :: !Text
|
||||
, menuItemClasses :: ![ Text ]
|
||||
, menuItemAction :: !action
|
||||
, menuItemAccel :: !( Maybe ( Word32, [ Modifier ] ) )
|
||||
, submenuDescription :: !( submenu Description )
|
||||
}
|
||||
data instance MenuItem action submenu Object
|
||||
= MenuItem
|
||||
{ menuItem :: !GTK.MenuItem
|
||||
, menuItemSubmenu :: !( submenu Object )
|
||||
}
|
||||
menuActionNames :: HashSet ActionName
|
||||
menuActionNames = HashSet.fromList
|
||||
-- file menu
|
||||
[ WinAction "newFile"
|
||||
, WinAction "openFile"
|
||||
, WinAction "openFolder"
|
||||
, WinAction "save"
|
||||
, WinAction "saveAs"
|
||||
, WinAction "closeActive"
|
||||
, WinAction "quit"
|
||||
-- edit menu
|
||||
, WinAction "undo"
|
||||
, WinAction "redo"
|
||||
, WinAction "cut"
|
||||
, WinAction "copy"
|
||||
, WinAction "paste"
|
||||
, WinAction "duplicate"
|
||||
, WinAction "delete"
|
||||
-- view menu
|
||||
, WinAction "toggleGuides"
|
||||
-- about menu
|
||||
, AppAction "about"
|
||||
]
|
||||
|
||||
data family Separator ( r :: ResourceType )
|
||||
data instance Separator Description
|
||||
= SeparatorDescription
|
||||
{ separatorClasses :: ![ Text ] }
|
||||
data instance Separator Object
|
||||
= Separator
|
||||
{ separatorItem :: !GTK.MenuItem }
|
||||
|
||||
data NoSubresource ( k :: ResourceType ) = NoSubresource
|
||||
createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction )
|
||||
createMenuActions =
|
||||
HashMap.traverseWithKey
|
||||
( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing )
|
||||
( HashSet.toMap menuActionNames )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Menu used in MetaBrush.
|
||||
|
||||
-- Types.
|
||||
menuDescription :: [ MenuItem ]
|
||||
menuDescription =
|
||||
[ SubmenuDescription ( Just "File" ) fileMenuDescription
|
||||
, SubmenuDescription ( Just "Edit" ) editMenuDescription
|
||||
, SubmenuDescription ( Just "View" ) viewMenuDescription
|
||||
, SubmenuDescription ( Just "Help" ) helpMenuDescription
|
||||
]
|
||||
|
||||
data Menu ( rt :: ResourceType )
|
||||
= Menu
|
||||
{ file :: !( MenuItem () FileMenu rt )
|
||||
, edit :: !( MenuItem () EditMenu rt )
|
||||
, view :: !( MenuItem () ViewMenu rt )
|
||||
, help :: !( MenuItem () HelpMenu rt )
|
||||
}
|
||||
deriving stock Generic
|
||||
fileMenuDescription :: [ MenuItem ]
|
||||
fileMenuDescription =
|
||||
[ MenuItemDescription "New" ( Just $ WinAction "newFile" , ( NewFile AfterCurrentTab ) ) ( Just "<Control>n" )
|
||||
, MenuItemDescription "Open file" ( Just $ WinAction "openFile" , ( OpenFile AfterCurrentTab ) ) ( Just "<Control>o" )
|
||||
, MenuItemDescription "Open folder" ( Just $ WinAction "openFolder" , ( OpenFolder AfterCurrentTab ) ) ( Just "<Control><Shift>o" )
|
||||
, MenuItemDescription "Save" ( Just $ WinAction "save" , Save ) ( Just "<Control>s" )
|
||||
, MenuItemDescription "Save as" ( Just $ WinAction "saveAs" , SaveAs ) ( Just "<Control><Shift>s" )
|
||||
, MenuItemDescription "Close" ( Just $ WinAction "closeActive", CloseActive ) ( Just "<Control>w" )
|
||||
, MenuItemDescription "Quit" ( Just $ WinAction "quit" , Quit ) ( Just "<Control>q" )
|
||||
]
|
||||
|
||||
data FileMenu ( rt :: ResourceType )
|
||||
= FileMenu
|
||||
{ new :: !( MenuItem NewFile NoSubresource rt )
|
||||
, openFile :: !( MenuItem OpenFile NoSubresource rt )
|
||||
, openFolder :: !( MenuItem OpenFolder NoSubresource rt )
|
||||
, save :: !( MenuItem Save NoSubresource rt )
|
||||
, saveAs :: !( MenuItem SaveAs NoSubresource rt )
|
||||
, close :: !( MenuItem Close NoSubresource rt )
|
||||
, quit :: !( MenuItem Quit NoSubresource rt )
|
||||
}
|
||||
deriving stock Generic
|
||||
editMenuDescription :: [ MenuItem ]
|
||||
editMenuDescription =
|
||||
[ Section Nothing
|
||||
[ MenuItemDescription "Undo" ( Just $ WinAction "undo", Undo ) ( Just "<Control>z" )
|
||||
, MenuItemDescription "Redo" ( Just $ WinAction "redo", Redo ) ( Just "<Control>y" )
|
||||
]
|
||||
, Section Nothing
|
||||
[ MenuItemDescription "Cut" ( Just $ WinAction "cut" , Cut ) ( Just "<Control>x" )
|
||||
, MenuItemDescription "Copy" ( Just $ WinAction "copy" , Copy ) ( Just "<Control>c" )
|
||||
, MenuItemDescription "Paste" ( Just $ WinAction "paste" , Paste ) ( Just "<Control>v" )
|
||||
, MenuItemDescription "Duplicate" ( Just $ WinAction "duplicate", Duplicate ) ( Just "<Control>d" )
|
||||
, MenuItemDescription "Delete" ( Just $ WinAction "delete" , Delete ) ( Just "Delete" )
|
||||
]
|
||||
, Section Nothing
|
||||
[ MenuItemDescription "Preferences" ( Nothing, () ) ( Just "<Control><Shift>p" )
|
||||
]
|
||||
]
|
||||
|
||||
data EditMenu ( rt :: ResourceType )
|
||||
= EditMenu
|
||||
{ undo :: !( MenuItem Undo NoSubresource rt )
|
||||
, redo :: !( MenuItem Redo NoSubresource rt )
|
||||
, editSep1 :: !( Separator rt )
|
||||
, cut :: !( MenuItem Cut NoSubresource rt )
|
||||
, copy :: !( MenuItem Copy NoSubresource rt )
|
||||
, paste :: !( MenuItem Paste NoSubresource rt )
|
||||
, duplicate :: !( MenuItem Duplicate NoSubresource rt )
|
||||
, delete :: !( MenuItem Delete NoSubresource rt )
|
||||
, editSep2 :: !( Separator rt )
|
||||
, preferences :: !( MenuItem () NoSubresource rt )
|
||||
}
|
||||
deriving stock Generic
|
||||
viewMenuDescription :: [ MenuItem ]
|
||||
viewMenuDescription =
|
||||
[ Section Nothing
|
||||
[ MenuItemDescription "Navigator" ( Nothing, () ) Nothing
|
||||
, MenuItemDescription "History" ( Nothing, () ) ( Just "<Control>h" )
|
||||
]
|
||||
, Section Nothing
|
||||
[ MenuItemDescription "Strokes" ( Nothing, () ) Nothing
|
||||
, MenuItemDescription "Brushes" ( Nothing, () ) Nothing
|
||||
, MenuItemDescription "Metaparameters" ( Nothing, () ) Nothing
|
||||
]
|
||||
, Section Nothing
|
||||
[ MenuItemDescription "Transform" ( Nothing, () ) Nothing
|
||||
]
|
||||
, Section Nothing
|
||||
[ MenuItemDescription "Toggle guides" ( Just $ WinAction "toggleGuides", ToggleGuides ) ( Just "g" )
|
||||
]
|
||||
]
|
||||
|
||||
data ViewMenu ( rt :: ResourceType )
|
||||
= ViewMenu
|
||||
{ navigator :: !( MenuItem () NoSubresource rt )
|
||||
, history :: !( MenuItem () NoSubresource rt )
|
||||
, viewSep1 :: !( Separator rt )
|
||||
, strokes :: !( MenuItem () NoSubresource rt )
|
||||
, brushes :: !( MenuItem () NoSubresource rt )
|
||||
, metaparameters :: !( MenuItem () NoSubresource rt )
|
||||
, viewSep2 :: !( Separator rt )
|
||||
, transform :: !( MenuItem () NoSubresource rt )
|
||||
, viewSep3 :: !( Separator rt )
|
||||
, toggleGuides :: !( MenuItem ToggleGuides NoSubresource rt )
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
data HelpMenu ( rt :: ResourceType )
|
||||
= HelpMenu
|
||||
{ about :: !( MenuItem About NoSubresource rt ) }
|
||||
deriving stock Generic
|
||||
|
||||
-- Descriptions.
|
||||
|
||||
menuDescription :: Menu Description
|
||||
menuDescription
|
||||
= Menu
|
||||
{ file = MenuItemDescription "File" [ "menuItem", "file" ] () Nothing fileMenuDescription
|
||||
, edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] () Nothing editMenuDescription
|
||||
, view = MenuItemDescription "View" [ "menuItem", "view" ] () Nothing viewMenuDescription
|
||||
, help = MenuItemDescription "Help" [ "menuItem", "help" ] () Nothing helpMenuDescription
|
||||
}
|
||||
|
||||
fileMenuDescription :: FileMenu Description
|
||||
fileMenuDescription
|
||||
= FileMenu
|
||||
{ new = MenuItemDescription "New" [ "submenuItem" ] ( NewFile AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
|
||||
, openFile = MenuItemDescription "Open file" [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
|
||||
, openFolder = MenuItemDescription "Open folder" [ "submenuItem" ] ( OpenFolder AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L, Shift L ] ) ) NoSubresource
|
||||
, save = MenuItemDescription "Save" [ "submenuItem" ] Save ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
|
||||
, saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
|
||||
, close = MenuItemDescription "Close" [ "submenuItem" ] CloseActive ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
|
||||
, quit = MenuItemDescription "Quit" [ "submenuItem" ] Quit ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
|
||||
}
|
||||
|
||||
editMenuDescription :: EditMenu Description
|
||||
editMenuDescription
|
||||
= EditMenu
|
||||
{ undo = MenuItemDescription "Undo" [ "submenuItem" ] Undo ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
|
||||
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Redo ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
|
||||
, editSep1 = SeparatorDescription [ "submenuSeparator" ]
|
||||
, cut = MenuItemDescription "Cut" [ "submenuItem" ] Cut ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
|
||||
, copy = MenuItemDescription "Copy" [ "submenuItem" ] Copy ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
|
||||
, paste = MenuItemDescription "Paste" [ "submenuItem" ] Paste ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
|
||||
, duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Duplicate ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource
|
||||
, delete = MenuItemDescription "Delete" [ "submenuItem" ] Delete ( Just ( GDK.KEY_Delete, [] ) ) NoSubresource
|
||||
, editSep2 = SeparatorDescription [ "submenuSeparator" ]
|
||||
, preferences = MenuItemDescription "Preferences" [ "submenuItem" ] () ( Just ( GDK.KEY_P, [ Control L, Shift L ] ) ) NoSubresource
|
||||
}
|
||||
|
||||
viewMenuDescription :: ViewMenu Description
|
||||
viewMenuDescription
|
||||
= ViewMenu
|
||||
{ navigator = MenuItemDescription "Navigator" [ "submenuItem" ] () Nothing NoSubresource
|
||||
, history = MenuItemDescription "History" [ "submenuItem" ] () ( Just ( GDK.KEY_H, [ Control L ] ) ) NoSubresource
|
||||
, viewSep1 = SeparatorDescription [ "submenuSeparator" ]
|
||||
, strokes = MenuItemDescription "Strokes" [ "submenuItem" ] () Nothing NoSubresource
|
||||
, brushes = MenuItemDescription "Brushes" [ "submenuItem" ] () Nothing NoSubresource
|
||||
, metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] () Nothing NoSubresource
|
||||
, viewSep2 = SeparatorDescription [ "submenuSeparator" ]
|
||||
, transform = MenuItemDescription "Transform" [ "submenuItem" ] () Nothing NoSubresource
|
||||
, viewSep3 = SeparatorDescription [ "submenuSeparator" ]
|
||||
, toggleGuides = MenuItemDescription "Hide guides" [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource
|
||||
}
|
||||
|
||||
helpMenuDescription :: HelpMenu Description
|
||||
helpMenuDescription
|
||||
= HelpMenu
|
||||
{ about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] About ( Just ( GDK.KEY_question, [ Control L ] ) ) NoSubresource }
|
||||
helpMenuDescription :: [ MenuItem ]
|
||||
helpMenuDescription =
|
||||
[ MenuItemDescription "About MetaBrush" ( Just $ AppAction "about", About ) ( Just "<Ctrl>question" )
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Creating a GTK menu bar from a menu description.
|
||||
-- Creating a GTK popover menu bar from a menu description.
|
||||
|
||||
newMenuItem
|
||||
:: ( MonadIO m, HandleAction action )
|
||||
=> UIElements
|
||||
-> Variables
|
||||
-> GTK.AccelGroup
|
||||
-> MenuItem action submenu Description
|
||||
-> m GTK.MenuItem
|
||||
newMenuItem uiElts vars accelGroup ( MenuItemDescription {..} ) = do
|
||||
menuItem <- GTK.menuItemNewWithLabel menuItemLabel
|
||||
for_ menuItemAccel \ ( key, modifiers ) -> do
|
||||
GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
|
||||
GTK.containerForeach menuItem \ lbl -> widgetAddClass lbl "accelLabel"
|
||||
unless ( null menuItemClasses ) do
|
||||
widgetAddClasses menuItem menuItemClasses
|
||||
void $ GTK.onMenuItemActivate menuItem
|
||||
( handleAction uiElts vars menuItemAction )
|
||||
pure menuItem
|
||||
|
||||
class CreateMenuItem desc res | desc -> res, res -> desc where
|
||||
createMenuItem :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> ( GTK.MenuItem -> m () ) -> desc -> m res
|
||||
instance {-# OVERLAPPING #-}
|
||||
HandleAction action
|
||||
=> CreateMenuItem
|
||||
( MenuItem action NoSubresource Description )
|
||||
( MenuItem action NoSubresource Object )
|
||||
where
|
||||
createMenuItem uiElts vars accelGroup attachToParent menuItemDescription = do
|
||||
menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription
|
||||
attachToParent menuItem
|
||||
pure
|
||||
MenuItem
|
||||
{ menuItem = menuItem
|
||||
, menuItemSubmenu = NoSubresource
|
||||
}
|
||||
instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
|
||||
=> CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object )
|
||||
where
|
||||
createMenuItem uiElts vars accelGroup attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
|
||||
menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription
|
||||
submenu <- GTK.menuNew
|
||||
GTK.menuSetAccelGroup submenu ( Just accelGroup )
|
||||
submenuItems <-
|
||||
constraints @CreateMenuItem
|
||||
( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend submenu ) )
|
||||
submenuDescription
|
||||
GTK.menuItemSetSubmenu menuItem ( Just submenu )
|
||||
attachToParent menuItem
|
||||
pure
|
||||
MenuItem
|
||||
{ menuItem = menuItem
|
||||
, menuItemSubmenu = submenuItems
|
||||
}
|
||||
instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
|
||||
createMenuItem _ _ _ attachToParent ( SeparatorDescription {..} ) = do
|
||||
separator <- GTK.separatorMenuItemNew
|
||||
unless ( null separatorClasses ) do
|
||||
widgetAddClasses separator separatorClasses
|
||||
sep <- liftIO ( GTK.unsafeCastTo GTK.MenuItem separator )
|
||||
attachToParent sep
|
||||
pure ( Separator { separatorItem = sep } )
|
||||
|
||||
newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
|
||||
newMenuBar uiElts vars accelGroup = do
|
||||
menuBar <- GTK.menuBarNew
|
||||
menu <-
|
||||
constraints @CreateMenuItem
|
||||
( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend menuBar ) )
|
||||
menuDescription
|
||||
pure ( menuBar, menu )
|
||||
makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m ()
|
||||
makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case
|
||||
SubmenuDescription
|
||||
{ submenuLabel
|
||||
, submenuItems
|
||||
} -> do
|
||||
submenu <- GIO.menuNew
|
||||
makeMenu uiElts vars submenu submenuItems
|
||||
GIO.menuAppendSubmenu menu submenuLabel submenu
|
||||
MenuItemDescription
|
||||
{ menuItemLabel
|
||||
, menuItemAction = ( mbActionName, actionData )
|
||||
, menuItemAccel
|
||||
} -> do
|
||||
for_ mbActionName \ actionName -> do
|
||||
let
|
||||
simpleName :: Text
|
||||
simpleName = actionSimpleName actionName
|
||||
case HashMap.lookup actionName menuActions of
|
||||
Nothing ->
|
||||
error
|
||||
( "Could not create menu item labelled " <> Text.unpack menuItemLabel <>
|
||||
": missing action " <> show actionName
|
||||
)
|
||||
Just menuItemAction -> do
|
||||
_ <- GIO.onSimpleActionActivate menuItemAction
|
||||
( \ _ -> handleAction uiElts vars actionData )
|
||||
GIO.actionMapAddAction window menuItemAction
|
||||
for_ menuItemAccel \ accelText -> do
|
||||
actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing
|
||||
GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText]
|
||||
menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName )
|
||||
GIO.menuAppendItem menu menuItem
|
||||
Section
|
||||
{ sectionName
|
||||
, sectionItems
|
||||
} -> do
|
||||
section <- GIO.menuNew
|
||||
makeMenu uiElts vars section sectionItems
|
||||
GIO.menuAppendSection menu sectionName section
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Creating the menu bar from its declarative specification.
|
||||
|
||||
-- | Add the menu bar to the given box (title bar box).
|
||||
createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
|
||||
createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
|
||||
accelGroup <- GTK.accelGroupNew
|
||||
GTK.windowAddAccelGroup window accelGroup
|
||||
( menuBar, menu ) <- newMenuBar uiElts vars accelGroup
|
||||
widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
|
||||
GTK.boxPackStart titleBar menuBar False False 0
|
||||
createMenu :: MonadIO m => UIElements -> Variables -> m GIO.Menu
|
||||
createMenu uiElts vars = do
|
||||
menu <- GIO.menuNew
|
||||
makeMenu uiElts vars menu menuDescription
|
||||
pure menu
|
||||
|
||||
-- | Add the menu bar to the given box (title bar box).
|
||||
createMenuBar :: MonadIO m => UIElements -> Variables -> Colours -> m GTK.PopoverMenuBar
|
||||
createMenuBar uiElts@( UIElements { application, window, titleBar } ) vars colours = do
|
||||
--accelGroup <- GTK.accelGroupNew
|
||||
--GTK.windowAddAccelGroup window accelGroup
|
||||
menu <- createMenu uiElts vars
|
||||
menuBar <- GTK.popoverMenuBarNewFromModel ( Just menu )
|
||||
widgetAddClasses menuBar [ "menu", "text", "plain" ]
|
||||
GTK.headerBarPackStart titleBar menuBar
|
||||
|
||||
-- TODO: this is a bit of a workaround to add hover highlight to top-level menu items.
|
||||
-- Activating a menu somehow sets the "hover" setting,
|
||||
-- so instead we use the "selected" setting for actual hover highlighting.
|
||||
topLevelMenuItems <- GTK.containerGetChildren menuBar
|
||||
for_ topLevelMenuItems \ topLevelMenuItem -> do
|
||||
void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
|
||||
flags <- GTK.widgetGetStateFlags topLevelMenuItem
|
||||
GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
|
||||
pure False
|
||||
void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
|
||||
flags <- GTK.widgetGetStateFlags topLevelMenuItem
|
||||
GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
|
||||
pure False
|
||||
-- GTK4 FIXME
|
||||
--topLevelMenuItems <- GTK.containerGetChildren menuBar
|
||||
--for_ topLevelMenuItems \ topLevelMenuItem -> do
|
||||
-- void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
|
||||
-- flags <- GTK.widgetGetStateFlags topLevelMenuItem
|
||||
-- GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
|
||||
-- pure False
|
||||
-- void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
|
||||
-- flags <- GTK.widgetGetStateFlags topLevelMenuItem
|
||||
-- GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
|
||||
-- pure False
|
||||
|
||||
windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClasses windowIcons [ "windowIcon" ]
|
||||
GTK.boxPackEnd titleBar windowIcons False False 0
|
||||
widgetAddClasses windowIcons [ "windowIcons" ]
|
||||
GTK.headerBarPackEnd titleBar windowIcons
|
||||
|
||||
minimiseButton <- GTK.buttonNew
|
||||
fullscreenButton <- GTK.buttonNew
|
||||
closeButton <- GTK.buttonNew
|
||||
minimiseButton <- GTK.buttonNew
|
||||
maximiseButton <- GTK.buttonNew
|
||||
closeButton <- GTK.buttonNew
|
||||
|
||||
GTK.boxPackStart windowIcons minimiseButton True True 0
|
||||
GTK.boxPackStart windowIcons fullscreenButton True True 0
|
||||
GTK.boxPackStart windowIcons closeButton True True 0
|
||||
GTK.boxAppend windowIcons minimiseButton
|
||||
GTK.boxAppend windowIcons maximiseButton
|
||||
GTK.boxAppend windowIcons closeButton
|
||||
|
||||
minimiseArea <- GTK.drawingAreaNew
|
||||
fullscreenArea <- GTK.drawingAreaNew
|
||||
closeArea <- GTK.drawingAreaNew
|
||||
minimiseArea <- GTK.drawingAreaNew
|
||||
maximiseArea <- GTK.drawingAreaNew
|
||||
closeArea <- GTK.drawingAreaNew
|
||||
|
||||
GTK.containerAdd minimiseButton minimiseArea
|
||||
GTK.containerAdd fullscreenButton fullscreenArea
|
||||
GTK.containerAdd closeButton closeArea
|
||||
GTK.buttonSetChild minimiseButton ( Just minimiseArea )
|
||||
GTK.buttonSetChild maximiseButton ( Just maximiseArea )
|
||||
GTK.buttonSetChild closeButton ( Just closeArea )
|
||||
|
||||
void $ GTK.onWidgetDraw minimiseArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawMinimise colours )
|
||||
GTK.drawingAreaSetDrawFunc minimiseArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawMinimise colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do
|
||||
Just gdkWindow <- GTK.widgetGetWindow window
|
||||
windowState <- GDK.windowGetState gdkWindow
|
||||
if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState
|
||||
then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
|
||||
else Cairo.renderWithContext ( drawMaximise colours ) cairoContext
|
||||
GTK.drawingAreaSetDrawFunc maximiseArea $ Just \ _ cairoContext _ _ -> do
|
||||
isMaximised <- GTK.getWindowMaximized window
|
||||
if isMaximised
|
||||
then void $ Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
|
||||
else void $ Cairo.renderWithContext ( drawMaximise colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw closeArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawClose colours )
|
||||
GTK.drawingAreaSetDrawFunc closeArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawClose colours ) cairoContext
|
||||
|
||||
for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
|
||||
for_ [ minimiseButton, maximiseButton, closeButton ] \ button -> do
|
||||
widgetAddClass button "windowIcon"
|
||||
|
||||
widgetAddClass closeButton "closeWindowIcon"
|
||||
|
|
@ -367,18 +292,17 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
|
|||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
_ <- GTK.onButtonClicked closeButton ( quitEverything window )
|
||||
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
|
||||
_ <- GTK.onButtonClicked fullscreenButton do
|
||||
Just gdkWindow <- GTK.widgetGetWindow window
|
||||
windowState <- GDK.windowGetState gdkWindow
|
||||
if GDK.WindowStateFullscreen `elem` windowState
|
||||
then GTK.windowUnfullscreen window
|
||||
else
|
||||
if GDK.WindowStateMaximized `elem` windowState
|
||||
then GTK.windowUnmaximize window
|
||||
else GTK.windowMaximize window
|
||||
_ <- GTK.onButtonClicked closeButton ( quitEverything application window )
|
||||
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowMinimize window )
|
||||
_ <- GTK.onButtonClicked maximiseButton do
|
||||
isMaximised <- GTK.getWindowMaximized window
|
||||
if isMaximised
|
||||
then GTK.windowUnmaximize window
|
||||
else GTK.windowMaximize window
|
||||
GTK.widgetQueueDraw maximiseArea
|
||||
|
||||
---------------------------------------------------------
|
||||
|
||||
pure menu
|
||||
GTK.applicationSetMenubar application ( Just menu )
|
||||
|
||||
pure menuBar
|
||||
|
|
|
|||
|
|
@ -1,53 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module MetaBrush.UI.Menu
|
||||
( ResourceType(..), MenuItem
|
||||
, Menu
|
||||
, FileMenu, EditMenu, ViewMenu, HelpMenu
|
||||
, newMenuBar, createMenuBar
|
||||
) where
|
||||
|
||||
-- base
|
||||
import Data.Kind
|
||||
( Type )
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
( UIElements, Variables )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ResourceType
|
||||
= Description
|
||||
| Object
|
||||
|
||||
data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
|
||||
|
||||
data Menu ( rt :: ResourceType )
|
||||
type role Menu nominal
|
||||
|
||||
data FileMenu ( rt :: ResourceType )
|
||||
type role FileMenu nominal
|
||||
|
||||
data EditMenu ( rt :: ResourceType )
|
||||
type role EditMenu nominal
|
||||
|
||||
data ViewMenu ( rt :: ResourceType )
|
||||
type role ViewMenu nominal
|
||||
|
||||
data HelpMenu ( rt :: ResourceType )
|
||||
type role HelpMenu nominal
|
||||
|
||||
newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
|
||||
|
||||
createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
|
||||
|
|
@ -27,7 +27,8 @@ createPanelBar panelBox = do
|
|||
widgetAddClass panelBox "panels"
|
||||
|
||||
pane1 <- GTK.panedNew GTK.OrientationVertical
|
||||
GTK.boxPackStart panelBox pane1 True True 0
|
||||
GTK.widgetSetVexpand pane1 True
|
||||
GTK.boxAppend panelBox pane1
|
||||
|
||||
panels1 <- GTK.notebookNew
|
||||
panels2 <- GTK.notebookNew
|
||||
|
|
@ -35,8 +36,8 @@ createPanelBar panelBox = do
|
|||
GTK.notebookSetGroupName panels1 ( Just "Panel" )
|
||||
GTK.notebookSetGroupName panels2 ( Just "Panel" )
|
||||
|
||||
GTK.panedPack1 pane1 panels1 True True
|
||||
GTK.panedPack2 pane1 panels2 True True
|
||||
GTK.panedSetStartChild pane1 panels1
|
||||
GTK.panedSetEndChild pane1 panels2
|
||||
|
||||
strokesPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||||
brushesPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
|
@ -75,9 +76,9 @@ createPanelBar panelBox = do
|
|||
transformContent <- GTK.labelNew ( Just "Transform tab content..." )
|
||||
historyContent <- GTK.labelNew ( Just "History tab content..." )
|
||||
|
||||
GTK.boxPackStart strokesPanel strokesContent True True 0
|
||||
GTK.boxPackStart brushesPanel brushesContent True True 0
|
||||
GTK.boxPackStart transformPanel transformContent True True 0
|
||||
GTK.boxPackStart historyPanel historyContent True True 0
|
||||
GTK.boxAppend strokesPanel strokesContent
|
||||
GTK.boxAppend brushesPanel brushesContent
|
||||
GTK.boxAppend transformPanel transformContent
|
||||
GTK.boxAppend historyPanel historyContent
|
||||
|
||||
pure ()
|
||||
|
|
|
|||
|
|
@ -11,8 +11,10 @@ module MetaBrush.UI.ToolBar
|
|||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( second )
|
||||
import Control.Monad
|
||||
( void )
|
||||
( void, when )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
|
||||
|
|
@ -56,8 +58,9 @@ data Mode
|
|||
|
||||
data ToolBar
|
||||
= ToolBar
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton
|
||||
, debugTool :: !GTK.ToggleButton }
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
|
||||
:: !GTK.ToggleButton
|
||||
}
|
||||
|
||||
createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar
|
||||
createToolBar ( Variables {..} ) colours toolBar = do
|
||||
|
|
@ -67,30 +70,35 @@ createToolBar ( Variables {..} ) colours toolBar = do
|
|||
GTK.widgetSetValign toolBar GTK.AlignStart
|
||||
GTK.widgetSetVexpand toolBar True
|
||||
|
||||
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||||
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool )
|
||||
|
||||
_ <- GTK.onButtonClicked selectionTool $ STM.atomically do
|
||||
STM.writeTVar toolTVar Selection
|
||||
_ <- GTK.onButtonClicked penTool $ STM.atomically do
|
||||
STM.writeTVar toolTVar Pen
|
||||
selectionTool <- GTK.toggleButtonNew
|
||||
penTool <- GTK.toggleButtonNew
|
||||
GTK.toggleButtonSetGroup penTool ( Just selectionTool )
|
||||
makeToggleGroup $
|
||||
fmap
|
||||
( second \ toolVal -> STM.atomically do
|
||||
STM.writeTVar toolTVar toolVal
|
||||
STM.writeTVar partialPathTVar Nothing
|
||||
STM.writeTVar recomputeStrokesTVar True
|
||||
)
|
||||
[ ( selectionTool, Selection ), ( penTool, Pen ) ]
|
||||
GTK.toggleButtonSetActive selectionTool True
|
||||
|
||||
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||||
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
|
||||
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
|
||||
|
||||
_ <- GTK.onButtonClicked pathTool $ STM.atomically do
|
||||
STM.writeTVar modeTVar PathMode
|
||||
STM.writeTVar recomputeStrokesTVar True
|
||||
_ <- GTK.onButtonClicked brushTool $ STM.atomically do
|
||||
STM.writeTVar modeTVar BrushMode
|
||||
STM.writeTVar recomputeStrokesTVar True
|
||||
_ <- GTK.onButtonClicked metaTool $ STM.atomically do
|
||||
STM.writeTVar modeTVar MetaMode
|
||||
STM.writeTVar recomputeStrokesTVar True
|
||||
|
||||
pathTool <- GTK.toggleButtonNew
|
||||
brushTool <- GTK.toggleButtonNew
|
||||
metaTool <- GTK.toggleButtonNew
|
||||
GTK.toggleButtonSetGroup brushTool ( Just pathTool )
|
||||
GTK.toggleButtonSetGroup metaTool ( Just pathTool )
|
||||
makeToggleGroup $
|
||||
fmap
|
||||
( second \ modeVal -> STM.atomically do
|
||||
STM.writeTVar modeTVar modeVal
|
||||
STM.writeTVar partialPathTVar Nothing
|
||||
STM.writeTVar recomputeStrokesTVar True
|
||||
)
|
||||
[ ( pathTool, PathMode ), ( brushTool, BrushMode ), ( metaTool, MetaMode ) ]
|
||||
GTK.toggleButtonSetActive pathTool True
|
||||
|
||||
toolSep2 <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
|
|
@ -100,20 +108,22 @@ createToolBar ( Variables {..} ) colours toolBar = do
|
|||
clicked <- GTK.toggleButtonGetActive debugTool
|
||||
STM.atomically do
|
||||
STM.writeTVar debugTVar clicked
|
||||
STM.writeTVar partialPathTVar Nothing
|
||||
STM.writeTVar recomputeStrokesTVar True
|
||||
|
||||
GTK.boxPackStart toolBar selectionTool True True 0
|
||||
GTK.boxPackStart toolBar penTool True True 0
|
||||
GTK.boxPackStart toolBar toolSep1 True True 0
|
||||
GTK.boxPackStart toolBar pathTool True True 0
|
||||
GTK.boxPackStart toolBar brushTool True True 0
|
||||
GTK.boxPackStart toolBar metaTool True True 0
|
||||
GTK.boxPackStart toolBar toolSep2 True True 0
|
||||
GTK.boxPackStart toolBar debugTool True True 0
|
||||
GTK.boxAppend toolBar selectionTool
|
||||
GTK.boxAppend toolBar penTool
|
||||
GTK.boxAppend toolBar toolSep1
|
||||
GTK.boxAppend toolBar pathTool
|
||||
GTK.boxAppend toolBar brushTool
|
||||
GTK.boxAppend toolBar metaTool
|
||||
GTK.boxAppend toolBar toolSep2
|
||||
GTK.boxAppend toolBar debugTool
|
||||
|
||||
for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do
|
||||
GTK.toggleButtonSetMode tool False -- don't display radio indicator
|
||||
for_ [ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool ] \ tool -> do
|
||||
widgetAddClass tool "toolItem"
|
||||
GTK.widgetSetFocusOnClick tool False
|
||||
GTK.widgetSetFocusable tool False
|
||||
|
||||
widgetAddClass debugTool "toolItem"
|
||||
|
||||
|
|
@ -134,35 +144,37 @@ createToolBar ( Variables {..} ) colours toolBar = do
|
|||
metaToolArea <- GTK.drawingAreaNew
|
||||
debugToolArea <- GTK.drawingAreaNew
|
||||
|
||||
GTK.containerAdd selectionTool selectionToolArea
|
||||
GTK.containerAdd penTool penToolArea
|
||||
GTK.containerAdd pathTool pathToolArea
|
||||
GTK.containerAdd brushTool brushToolArea
|
||||
GTK.containerAdd metaTool metaToolArea
|
||||
GTK.containerAdd debugTool debugToolArea
|
||||
GTK.buttonSetChild selectionTool ( Just selectionToolArea )
|
||||
GTK.buttonSetChild penTool ( Just penToolArea )
|
||||
GTK.buttonSetChild pathTool ( Just pathToolArea )
|
||||
GTK.buttonSetChild brushTool ( Just brushToolArea )
|
||||
GTK.buttonSetChild metaTool ( Just metaToolArea )
|
||||
GTK.buttonSetChild debugTool ( Just debugToolArea )
|
||||
|
||||
void $ GTK.onWidgetDraw selectionToolArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawCursorIcon colours )
|
||||
GTK.drawingAreaSetDrawFunc selectionToolArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawCursorIcon colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw penToolArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawPen colours )
|
||||
GTK.drawingAreaSetDrawFunc penToolArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawPen colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw pathToolArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawPath colours )
|
||||
GTK.drawingAreaSetDrawFunc pathToolArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawPath colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw brushToolArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawBrush colours )
|
||||
GTK.drawingAreaSetDrawFunc brushToolArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawBrush colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw metaToolArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawMeta colours )
|
||||
GTK.drawingAreaSetDrawFunc metaToolArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawMeta colours ) cairoContext
|
||||
|
||||
void $ GTK.onWidgetDraw debugToolArea
|
||||
$ Cairo.renderWithContext
|
||||
( drawBug colours )
|
||||
GTK.drawingAreaSetDrawFunc debugToolArea $ Just \ _ cairoContext _ _ ->
|
||||
void $ Cairo.renderWithContext ( drawBug colours ) cairoContext
|
||||
|
||||
pure ( ToolBar {..} )
|
||||
|
||||
makeToggleGroup :: [ ( GTK.ToggleButton, IO () ) ] -> IO ()
|
||||
makeToggleGroup buttons =
|
||||
for_ buttons \ ( button, action ) ->
|
||||
GTK.afterToggleButtonToggled button do
|
||||
isActive <- GTK.toggleButtonGetActive button
|
||||
GTK.widgetSetSensitive button ( not isActive )
|
||||
when isActive action
|
||||
|
|
|
|||
|
|
@ -24,6 +24,6 @@ instance Show Mode
|
|||
|
||||
data ToolBar
|
||||
= ToolBar
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton
|
||||
, debugTool :: !GTK.ToggleButton
|
||||
{ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
|
||||
:: !GTK.ToggleButton
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module MetaBrush.UI.Viewport
|
||||
( Viewport(..), createViewport
|
||||
( Viewport(..), ViewportEventControllers(..)
|
||||
, createViewport
|
||||
, Ruler(..)
|
||||
)
|
||||
where
|
||||
|
|
@ -13,9 +14,6 @@ module MetaBrush.UI.Viewport
|
|||
import Data.Foldable
|
||||
( for_ )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
|
|
@ -25,6 +23,13 @@ import MetaBrush.Util
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data ViewportEventControllers
|
||||
= ViewportEventControllers
|
||||
{ viewportMotionController :: !GTK.EventControllerMotion
|
||||
, viewportScrollController :: !GTK.EventControllerScroll
|
||||
, viewportClicksController :: !GTK.GestureClick
|
||||
}
|
||||
|
||||
data Viewport
|
||||
= Viewport
|
||||
{ viewportDrawingArea
|
||||
|
|
@ -32,6 +37,11 @@ data Viewport
|
|||
, leftRulerDrawingArea
|
||||
, topRulerDrawingArea
|
||||
:: !GTK.DrawingArea
|
||||
, viewportEventControllers
|
||||
, rulerCornerEventControllers
|
||||
, leftRulerEventControllers
|
||||
, topRulerEventControllers
|
||||
:: !ViewportEventControllers
|
||||
}
|
||||
|
||||
createViewport :: GTK.Grid -> IO Viewport
|
||||
|
|
@ -56,9 +66,9 @@ createViewport viewportGrid = do
|
|||
leftRuler <- GTK.boxNew GTK.OrientationVertical 0
|
||||
topRuler <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
|
||||
GTK.containerAdd rvRulerCorner rulerCorner
|
||||
GTK.containerAdd rvLeftRuler leftRuler
|
||||
GTK.containerAdd rvTopRuler topRuler
|
||||
GTK.revealerSetChild rvRulerCorner ( Just rulerCorner )
|
||||
GTK.revealerSetChild rvLeftRuler ( Just leftRuler )
|
||||
GTK.revealerSetChild rvTopRuler ( Just topRuler )
|
||||
|
||||
widgetAddClasses rulerCorner [ "ruler", "rulerCorner" ]
|
||||
widgetAddClasses leftRuler [ "ruler", "leftRuler" ]
|
||||
|
|
@ -73,13 +83,13 @@ createViewport viewportGrid = do
|
|||
GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp
|
||||
|
||||
rulerCornerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0
|
||||
GTK.boxAppend rulerCorner rulerCornerDrawingArea
|
||||
|
||||
leftRulerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart leftRuler leftRulerDrawingArea True True 0
|
||||
GTK.boxAppend leftRuler leftRulerDrawingArea
|
||||
|
||||
topRulerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart topRuler topRulerDrawingArea True True 0
|
||||
GTK.boxAppend topRuler topRulerDrawingArea
|
||||
|
||||
GTK.widgetSetHexpand rulerCorner False
|
||||
GTK.widgetSetVexpand rulerCorner False
|
||||
|
|
@ -91,14 +101,49 @@ createViewport viewportGrid = do
|
|||
GTK.widgetSetVexpand viewportOverlay True
|
||||
|
||||
viewportDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.setContainerChild viewportOverlay viewportDrawingArea
|
||||
GTK.overlaySetChild viewportOverlay ( Just viewportDrawingArea )
|
||||
|
||||
for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetAddEvents drawingArea
|
||||
[ GDK.EventMaskPointerMotionMask
|
||||
, GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
|
||||
, GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask
|
||||
]
|
||||
-- Adding mouse event controllers to all drawing areas.
|
||||
viewportMotion <- GTK.eventControllerMotionNew
|
||||
viewportScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
|
||||
viewportClicks <- GTK.gestureClickNew
|
||||
GTK.gestureSingleSetButton viewportClicks 0
|
||||
let
|
||||
viewportEventControllers :: ViewportEventControllers
|
||||
viewportEventControllers =
|
||||
ViewportEventControllers viewportMotion viewportScroll viewportClicks
|
||||
|
||||
rulerCornerMotion <- GTK.eventControllerMotionNew
|
||||
rulerCornerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
|
||||
rulerCornerClicks <- GTK.gestureClickNew
|
||||
GTK.gestureSingleSetButton rulerCornerClicks 0
|
||||
let
|
||||
rulerCornerEventControllers :: ViewportEventControllers
|
||||
rulerCornerEventControllers =
|
||||
ViewportEventControllers rulerCornerMotion rulerCornerScroll rulerCornerClicks
|
||||
|
||||
leftRulerMotion <- GTK.eventControllerMotionNew
|
||||
leftRulerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
|
||||
leftRulerClicks <- GTK.gestureClickNew
|
||||
GTK.gestureSingleSetButton leftRulerClicks 0
|
||||
let
|
||||
leftRulerEventControllers :: ViewportEventControllers
|
||||
leftRulerEventControllers =
|
||||
ViewportEventControllers leftRulerMotion leftRulerScroll leftRulerClicks
|
||||
|
||||
topRulerMotion <- GTK.eventControllerMotionNew
|
||||
topRulerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
|
||||
topRulerClicks <- GTK.gestureClickNew
|
||||
GTK.gestureSingleSetButton topRulerClicks 0
|
||||
let
|
||||
topRulerEventControllers :: ViewportEventControllers
|
||||
topRulerEventControllers =
|
||||
ViewportEventControllers topRulerMotion topRulerScroll topRulerClicks
|
||||
|
||||
for_ [ viewportDrawingArea, rulerCornerDrawingArea, topRulerDrawingArea ]
|
||||
( `GTK.widgetSetHexpand` True )
|
||||
for_ [ viewportDrawingArea, rulerCornerDrawingArea, leftRulerDrawingArea ]
|
||||
( `GTK.widgetSetVexpand` True )
|
||||
|
||||
{-
|
||||
-----------------
|
||||
|
|
|
|||
|
|
@ -43,10 +43,10 @@ import Control.Monad.Trans.Maybe
|
|||
|
||||
withRGBA :: MonadIO m => GDK.RGBA -> ( Double -> Double -> Double -> Double -> m b ) -> m b
|
||||
withRGBA rgba f = do
|
||||
r <- GDK.getRGBARed rgba
|
||||
g <- GDK.getRGBAGreen rgba
|
||||
b <- GDK.getRGBABlue rgba
|
||||
a <- GDK.getRGBAAlpha rgba
|
||||
r <- realToFrac <$> GDK.getRGBARed rgba
|
||||
g <- realToFrac <$> GDK.getRGBAGreen rgba
|
||||
b <- realToFrac <$> GDK.getRGBABlue rgba
|
||||
a <- realToFrac <$> GDK.getRGBAAlpha rgba
|
||||
f r g b a
|
||||
|
||||
showRGBA :: MonadIO m => GDK.RGBA -> m String
|
||||
|
|
|
|||
Loading…
Reference in a new issue