metabrush/src/app/MetaBrush/UI/ToolBar.hs

144 lines
4.1 KiB
Haskell
Raw Normal View History

2020-08-13 22:47:10 +00:00
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.ToolBar
2020-08-13 22:47:10 +00:00
( Tool(..), Mode(..)
, ToolBar(..), createToolBar
)
where
-- base
import Control.Monad
( void )
import Data.Foldable
( for_ )
-- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext )
-- gi-gtk
import qualified GI.Gtk as GTK
2020-08-13 22:47:10 +00:00
-- stm
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, writeTVar )
-- MetaBrush
import MetaBrush.Asset.Colours
( Colours )
import MetaBrush.Asset.Cursor
( drawCursorIcon )
import MetaBrush.Asset.Tools
( drawBrush, drawMeta, drawPath, drawPen )
import MetaBrush.Render.Util
( widgetAddClass )
--------------------------------------------------------------------------------
2020-08-13 22:47:10 +00:00
data Tool
= Selection
| Pen
deriving stock Show
data Mode
= Path
| Brush
| Meta
deriving stock Show
data ToolBar
= ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton }
2020-08-20 01:57:26 +00:00
createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.DrawingArea -> GTK.Box -> IO ToolBar
createToolBar toolTVar modeTVar colours drawingArea toolBar = do
widgetAddClass toolBar "toolBar"
GTK.widgetSetValign toolBar GTK.AlignStart
GTK.widgetSetVexpand toolBar True
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool )
2020-08-13 22:47:10 +00:00
_ <- GTK.onButtonClicked selectionTool
( STM.atomically $ STM.writeTVar toolTVar Selection )
_ <- GTK.onButtonClicked penTool
( STM.atomically $ STM.writeTVar toolTVar Pen )
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
2020-08-20 01:57:26 +00:00
_ <- GTK.onButtonClicked pathTool do
STM.atomically $ STM.writeTVar modeTVar Path
GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked brushTool do
STM.atomically $ STM.writeTVar modeTVar Brush
GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked metaTool do
STM.atomically $ STM.writeTVar modeTVar Meta
GTK.widgetQueueDraw drawingArea
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
for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do
GTK.toggleButtonSetMode tool False -- don't display radio indicator
widgetAddClass tool "toolItem"
widgetAddClass toolSep1 "toolBarSeparator"
GTK.widgetSetTooltipText selectionTool ( Just "Select" )
GTK.widgetSetTooltipText penTool ( Just "Draw" )
GTK.widgetSetTooltipText pathTool ( Just "Brush path" )
GTK.widgetSetTooltipText brushTool ( Just "Brushes" )
GTK.widgetSetTooltipText metaTool ( Just "Meta-parameters" )
selectionToolArea <- GTK.drawingAreaNew
penToolArea <- GTK.drawingAreaNew
pathToolArea <- GTK.drawingAreaNew
brushToolArea <- GTK.drawingAreaNew
metaToolArea <- GTK.drawingAreaNew
GTK.containerAdd selectionTool selectionToolArea
GTK.containerAdd penTool penToolArea
GTK.containerAdd pathTool pathToolArea
GTK.containerAdd brushTool brushToolArea
GTK.containerAdd metaTool metaToolArea
void $ GTK.onWidgetDraw selectionToolArea
$ Cairo.renderWithContext
( drawCursorIcon colours )
void $ GTK.onWidgetDraw penToolArea
$ Cairo.renderWithContext
( drawPen colours )
void $ GTK.onWidgetDraw pathToolArea
$ Cairo.renderWithContext
( drawPath colours )
void $ GTK.onWidgetDraw brushToolArea
$ Cairo.renderWithContext
( drawBrush colours )
void $ GTK.onWidgetDraw metaToolArea
$ Cairo.renderWithContext
( drawMeta colours )
pure ( ToolBar { .. } )