mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 15:23:37 +00:00
113 lines
3.3 KiB
Haskell
113 lines
3.3 KiB
Haskell
|
{-# LANGUAGE BlockArguments #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE RecordWildCards #-}
|
||
|
|
{-# LANGUAGE TypeApplications #-}
|
||
|
|
|
||
|
|
module MetaBrush.UI.ToolBar
|
||
|
|
( 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
|
||
|
|
|
||
|
|
-- MetaBrush
|
||
|
|
import MetaBrush.Asset.Colours
|
||
|
|
( Colours )
|
||
|
|
import MetaBrush.Asset.Cursor
|
||
|
|
( drawCursorIcon )
|
||
|
|
import MetaBrush.Asset.Tools
|
||
|
|
( drawBrush, drawMeta, drawPath, drawPen )
|
||
|
|
import MetaBrush.Render.Util
|
||
|
|
( widgetAddClass )
|
||
|
|
|
||
|
|
--------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
data ToolBar
|
||
|
|
= ToolBar
|
||
|
|
{ selectionTool :: !GTK.RadioButton
|
||
|
|
, penTool :: !GTK.RadioButton
|
||
|
|
, pathTool :: !GTK.RadioButton
|
||
|
|
, brushTool :: !GTK.RadioButton
|
||
|
|
, metaTool :: !GTK.RadioButton
|
||
|
|
}
|
||
|
|
|
||
|
|
createToolBar :: Colours -> GTK.Box -> IO ToolBar
|
||
|
|
createToolBar colours toolBar = do
|
||
|
|
|
||
|
|
widgetAddClass toolBar "toolBar"
|
||
|
|
|
||
|
|
GTK.widgetSetValign toolBar GTK.AlignStart
|
||
|
|
GTK.widgetSetVexpand toolBar True
|
||
|
|
|
||
|
|
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||
|
|
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool )
|
||
|
|
|
||
|
|
pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||
|
|
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
|
||
|
|
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
|
||
|
|
|
||
|
|
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
|
||
|
|
|
||
|
|
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 { .. } )
|