Adapt to the changes in GTK4

This commit is contained in:
sheaf 2021-04-21 15:08:34 +00:00
commit 5717c80e93
22 changed files with 1500 additions and 1411 deletions

View file

@ -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

View file

@ -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 )

View file

@ -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 {

View file

@ -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

View file

@ -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

View file

@ -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

View 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 )

View file

@ -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

View file

@ -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

View file

@ -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 )

View file

@ -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 )

View file

@ -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

View file

@ -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 ()

View file

@ -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"

View file

@ -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 ()

View file

@ -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

View file

@ -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 )

View file

@ -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 ()

View file

@ -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

View file

@ -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
}

View file

@ -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 )
{-
-----------------

View file

@ -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