mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
733 lines
25 KiB
Haskell
733 lines
25 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
||
{-# LANGUAGE ConstraintKinds #-}
|
||
{-# LANGUAGE GADTs #-}
|
||
{-# LANGUAGE LambdaCase #-}
|
||
{-# LANGUAGE NamedFieldPuns #-}
|
||
{-# LANGUAGE NegativeLiterals #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE PatternSynonyms #-}
|
||
{-# LANGUAGE RecordWildCards #-}
|
||
{-# LANGUAGE TypeApplications #-}
|
||
|
||
module Main
|
||
( main )
|
||
where
|
||
|
||
-- base
|
||
import Control.Monad
|
||
( void, unless )
|
||
import Data.Foldable
|
||
( for_ )
|
||
import Data.Int
|
||
( Int32 )
|
||
import Data.Word
|
||
( Word32 )
|
||
import System.Exit
|
||
( exitSuccess )
|
||
|
||
-- acts
|
||
import Data.Act
|
||
( Act
|
||
( (•) )
|
||
)
|
||
|
||
-- containers
|
||
import Data.IntMap.Strict
|
||
( IntMap )
|
||
import qualified Data.IntMap.Strict as IntMap
|
||
( fromList, lookup, insert, traverseWithKey )
|
||
|
||
-- directory
|
||
import qualified System.Directory as Directory
|
||
( canonicalizePath )
|
||
|
||
-- gi-cairo-connector
|
||
import qualified GI.Cairo.Render.Connector as Cairo
|
||
( renderWithContext )
|
||
|
||
-- gi-cairo-render
|
||
import qualified GI.Cairo.Render as Cairo
|
||
|
||
-- gi-gdk
|
||
import qualified GI.Gdk as GDK
|
||
|
||
-- gi-gtk
|
||
import qualified GI.Gtk as GTK
|
||
|
||
-- stm
|
||
import qualified Control.Concurrent.STM as STM
|
||
( atomically )
|
||
import qualified Control.Concurrent.STM.TVar as STM
|
||
( newTVarIO, writeTVar, readTVarIO )
|
||
|
||
-- text
|
||
import qualified Data.Text as Text
|
||
( pack )
|
||
|
||
-- MetaBrush
|
||
import Math.Module
|
||
( (*^) )
|
||
import Math.Vector2D
|
||
( Point2D(..), Vector2D(..) )
|
||
import MetaBrush.Asset.Colours
|
||
( getColours )
|
||
import MetaBrush.Asset.Cursor
|
||
( drawCursorIcon )
|
||
import MetaBrush.Asset.InfoBar
|
||
( drawMagnifier, drawTopLeftCornerRect )
|
||
import MetaBrush.Asset.Logo
|
||
( drawLogo )
|
||
import MetaBrush.Asset.Tools
|
||
( drawBrush, drawMeta, drawPath, drawPen )
|
||
import MetaBrush.Asset.WindowIcons
|
||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||
import MetaBrush.Document
|
||
( Document(..)
|
||
, AABB(..)
|
||
, Stroke(..)
|
||
)
|
||
import MetaBrush.Event
|
||
( handleKeyboardPressEvent, handleKeyboardReleaseEvent
|
||
, pattern Control_L, pattern Control_R
|
||
, pattern Shift_L, pattern Shift_R
|
||
)
|
||
import MetaBrush.Render.Document
|
||
( renderDocument )
|
||
import MetaBrush.Render.Util
|
||
( widgetAddClass, widgetAddClasses )
|
||
import MetaBrush.UI.Menu
|
||
( newMenuBar )
|
||
import qualified Paths_MetaBrush as Cabal
|
||
( getDataFileName )
|
||
|
||
--------------------------------------------------------------------------------
|
||
|
||
testDocuments :: IntMap Document
|
||
testDocuments = IntMap.fromList
|
||
$ zip [0..]
|
||
[ Document
|
||
{ displayName = "Document 1"
|
||
, filePath = Nothing
|
||
, unsavedChanges = False
|
||
, strokes = [ Stroke [ Point2D 10 10, Point2D 30 30, Point2D 40 70 ] ]
|
||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
|
||
, viewportCenter = Point2D 50 50
|
||
, zoomFactor = 1
|
||
}
|
||
, Document
|
||
{ displayName = "Document 2"
|
||
, filePath = Nothing
|
||
, unsavedChanges = True
|
||
, strokes = [ Stroke [ Point2D 0 0, Point2D 10 10, Point2D 20 20 ] ]
|
||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
|
||
, viewportCenter = Point2D 10 10
|
||
, zoomFactor = 0.25
|
||
}
|
||
]
|
||
|
||
--------------------------------------------------------------------------------
|
||
|
||
main :: IO ()
|
||
main = do
|
||
|
||
---------------------------------------------------------
|
||
-- Initialise state
|
||
|
||
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
||
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
||
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
||
|
||
---------------------------------------------------------
|
||
-- 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 800 600
|
||
|
||
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
|
||
|
||
fileBar <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
|
||
viewportGrid <- GTK.gridNew
|
||
infoBar <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
|
||
GTK.boxPackStart mainView fileBar False False 0
|
||
GTK.boxPackStart mainView viewportGrid True True 0
|
||
GTK.boxPackStart mainView infoBar False False 0
|
||
|
||
---------------------------------------------------------
|
||
-- Background
|
||
|
||
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 )
|
||
|
||
------------
|
||
-- Menu bar
|
||
|
||
( menuBar, _menu ) <- newMenuBar
|
||
widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
|
||
GTK.boxPackStart titleBar menuBar False False 0
|
||
|
||
-- 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
|
||
|
||
windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
widgetAddClasses windowIcons [ "windowIcon" ]
|
||
GTK.boxPackEnd titleBar windowIcons False False 0
|
||
|
||
title <- GTK.labelNew ( Just "● New Document (1) – MetaBrush" )
|
||
widgetAddClasses title [ "text", "title", "plain" ]
|
||
GTK.boxSetCenterWidget titleBar ( Just title )
|
||
|
||
minimiseButton <- GTK.buttonNew
|
||
fullscreenButton <- 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
|
||
|
||
minimiseArea <- GTK.drawingAreaNew
|
||
fullscreenArea <- GTK.drawingAreaNew
|
||
closeArea <- GTK.drawingAreaNew
|
||
|
||
GTK.containerAdd minimiseButton minimiseArea
|
||
GTK.containerAdd fullscreenButton fullscreenArea
|
||
GTK.containerAdd closeButton closeArea
|
||
|
||
void $ GTK.onWidgetDraw minimiseArea
|
||
$ Cairo.renderWithContext
|
||
( drawMinimise colours )
|
||
|
||
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
|
||
|
||
void $ GTK.onWidgetDraw closeArea
|
||
$ Cairo.renderWithContext
|
||
( drawClose colours )
|
||
|
||
for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
|
||
widgetAddClass button "windowIcon"
|
||
|
||
widgetAddClass closeButton "closeWindowIcon"
|
||
|
||
---------------------------------------------------------
|
||
-- Tool bar
|
||
|
||
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 )
|
||
|
||
---------------------------------------------------------
|
||
-- Main viewport
|
||
|
||
widgetAddClass viewportGrid "viewport"
|
||
|
||
rvRulerCorner <- GTK.revealerNew
|
||
rvLeftRuler <- GTK.revealerNew
|
||
rvTopRuler <- GTK.revealerNew
|
||
viewportOverlay <- GTK.overlayNew
|
||
|
||
GTK.gridAttach viewportGrid rvRulerCorner 0 0 1 1
|
||
GTK.gridAttach viewportGrid rvLeftRuler 0 1 1 1
|
||
GTK.gridAttach viewportGrid rvTopRuler 1 0 1 1
|
||
GTK.gridAttach viewportGrid viewportOverlay 1 1 1 1
|
||
|
||
----------
|
||
-- Rulers
|
||
|
||
rulerCorner <- GTK.boxNew GTK.OrientationVertical 0
|
||
leftRuler <- GTK.boxNew GTK.OrientationVertical 0
|
||
topRuler <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
|
||
GTK.containerAdd rvRulerCorner rulerCorner
|
||
GTK.containerAdd rvLeftRuler leftRuler
|
||
GTK.containerAdd rvTopRuler topRuler
|
||
|
||
widgetAddClass rulerCorner "ruler"
|
||
widgetAddClass leftRuler "ruler"
|
||
widgetAddClass topRuler "ruler"
|
||
|
||
GTK.revealerSetRevealChild rvRulerCorner True
|
||
GTK.revealerSetRevealChild rvLeftRuler True
|
||
GTK.revealerSetRevealChild rvTopRuler True
|
||
|
||
GTK.revealerSetTransitionType rvRulerCorner GTK.RevealerTransitionTypeSlideLeft
|
||
GTK.revealerSetTransitionType rvLeftRuler GTK.RevealerTransitionTypeSlideLeft
|
||
GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp
|
||
|
||
rulerCornerArea <- GTK.drawingAreaNew
|
||
GTK.boxPackStart rulerCorner rulerCornerArea True True 0
|
||
|
||
leftRulerArea <- GTK.drawingAreaNew
|
||
GTK.boxPackStart leftRuler leftRulerArea True True 0
|
||
|
||
topRulerArea <- GTK.drawingAreaNew
|
||
GTK.boxPackStart topRuler topRulerArea True True 0
|
||
|
||
GTK.widgetSetHexpand rulerCorner False
|
||
GTK.widgetSetVexpand rulerCorner False
|
||
GTK.widgetSetHexpand leftRuler False
|
||
GTK.widgetSetVexpand leftRuler True
|
||
GTK.widgetSetHexpand topRuler True
|
||
GTK.widgetSetVexpand topRuler False
|
||
GTK.widgetSetHexpand viewportOverlay True
|
||
GTK.widgetSetVexpand viewportOverlay True
|
||
|
||
viewportArea <- GTK.drawingAreaNew
|
||
GTK.setContainerChild viewportOverlay viewportArea
|
||
|
||
-----------------
|
||
-- Viewport scrolling
|
||
|
||
viewportScrollbarGrid <- GTK.gridNew
|
||
GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid
|
||
GTK.overlaySetOverlayPassThrough viewportOverlay viewportScrollbarGrid True
|
||
|
||
viewportHScrollbar <- GTK.scrollbarNew GTK.OrientationHorizontal ( Nothing @GTK.Adjustment )
|
||
viewportVScrollbar <- GTK.scrollbarNew GTK.OrientationVertical ( Nothing @GTK.Adjustment )
|
||
GTK.widgetSetValign viewportHScrollbar GTK.AlignEnd
|
||
GTK.widgetSetHalign viewportVScrollbar GTK.AlignEnd
|
||
GTK.widgetSetVexpand viewportVScrollbar True
|
||
GTK.widgetSetHexpand viewportHScrollbar True
|
||
GTK.gridAttach viewportScrollbarGrid viewportHScrollbar 0 1 1 1
|
||
GTK.gridAttach viewportScrollbarGrid viewportVScrollbar 1 0 1 1
|
||
widgetAddClass viewportHScrollbar "viewportScrollbar"
|
||
widgetAddClass viewportVScrollbar "viewportScrollbar"
|
||
|
||
void $ GTK.onWidgetScrollEvent viewportArea \ scrollEvent -> do
|
||
|
||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||
--GDK.getEventScrollDirection scrollEvent
|
||
--GDK.getEventScrollType scrollEvent
|
||
--GDK.getEventScrollX scrollEvent
|
||
--GDK.getEventScrollY scrollEvent
|
||
|
||
unless ( dx == 0 && dy == 0 ) do
|
||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||
for_ mbActiveDoc \ i -> do
|
||
docs <- STM.readTVarIO openDocumentsTVar
|
||
for_ ( IntMap.lookup i docs ) \ ( doc@(Document { viewportCenter, zoomFactor } ) ) -> do
|
||
pressedKeys <- STM.readTVarIO pressedKeysTVar
|
||
let
|
||
newDoc :: Document
|
||
newDoc
|
||
-- Zooming using 'Control'.
|
||
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
|
||
= let
|
||
newZoomFactor :: Double
|
||
newZoomFactor
|
||
| dy > 0
|
||
= max 0.0078125 ( zoomFactor / 2 )
|
||
| otherwise
|
||
= zoomFactor * 2
|
||
in doc { zoomFactor = newZoomFactor }
|
||
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||
| dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
|
||
= let
|
||
newCenter :: Point2D Double
|
||
newCenter = ( ( 25 / zoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • viewportCenter
|
||
in doc { viewportCenter = newCenter }
|
||
-- Vertical scrolling.
|
||
| otherwise
|
||
= let
|
||
newCenter :: Point2D Double
|
||
newCenter = ( ( 25 / zoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • viewportCenter
|
||
in doc { viewportCenter = newCenter }
|
||
docs' :: IntMap Document
|
||
docs' = IntMap.insert i newDoc docs
|
||
STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
|
||
GTK.widgetQueueDraw viewportArea
|
||
pure True
|
||
|
||
-----------------
|
||
-- Rendering
|
||
|
||
void $ GTK.onWidgetDraw viewportArea \ctx -> do
|
||
-- Get the relevant document information
|
||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||
for_ mbActiveDoc \ i -> do
|
||
docs <- STM.readTVarIO openDocumentsTVar
|
||
for_ ( IntMap.lookup i docs ) \ doc -> do
|
||
( `Cairo.renderWithContext` ctx ) $ do
|
||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportArea
|
||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportArea
|
||
renderDocument colours ( viewportWidth, viewportHeight ) doc
|
||
pure True
|
||
|
||
---------------------------------------------------------
|
||
-- File bar
|
||
|
||
widgetAddClass fileBar "fileBar"
|
||
|
||
fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
GTK.containerAdd fileBar fileTabs
|
||
widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
|
||
|
||
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||
|
||
-- TODO: currently using static list of documents.
|
||
-- Need to dynamically update this widget as the user opens/closes documents.
|
||
fileButtons <- ( `IntMap.traverseWithKey` testDocuments ) \ i ( Document { displayName, unsavedChanges } ) -> do
|
||
-- File tab elements.
|
||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName
|
||
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
|
||
closeFileButton <- GTK.buttonNewWithLabel "x"
|
||
|
||
-- Create box for file tab elements.
|
||
tab <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
widgetAddClasses tab [ "fileBarTab" ]
|
||
GTK.boxPackStart fileTabs tab False False 0
|
||
GTK.boxPackStart tab pgButton True True 0
|
||
GTK.boxPackStart tab closeFileButton False False 0
|
||
|
||
widgetAddClasses pgButton [ "fileBarTabButton" ]
|
||
widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
|
||
|
||
-- Make both file tab elements activate styling on the whole tab
|
||
-- (e.g. hovering over the close file button should highlight the whole tab).
|
||
void $ GTK.onButtonClicked pgButton do
|
||
isActive <- GTK.toggleButtonGetActive pgButton
|
||
flags <- GTK.widgetGetStateFlags tab
|
||
if isActive
|
||
then do
|
||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
|
||
STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) )
|
||
GTK.widgetQueueDraw viewportArea
|
||
else
|
||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||
|
||
{-
|
||
void $ GTK.onButtonClicked closeFileButton do
|
||
closeFileDialog ...
|
||
-}
|
||
|
||
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
|
||
|
||
pure pgButton
|
||
|
||
GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
|
||
GTK.scrolledWindowSetOverlayScrolling fileBar True
|
||
|
||
---------------------------------------------------------
|
||
-- Panels
|
||
|
||
widgetAddClass panelBox "panels"
|
||
|
||
pane1 <- GTK.panedNew GTK.OrientationVertical
|
||
GTK.boxPackStart panelBox pane1 True True 0
|
||
|
||
panels1 <- GTK.notebookNew
|
||
panels2 <- GTK.notebookNew
|
||
|
||
GTK.notebookSetGroupName panels1 ( Just "Panel" )
|
||
GTK.notebookSetGroupName panels2 ( Just "Panel" )
|
||
|
||
GTK.panedPack1 pane1 panels1 True True
|
||
GTK.panedPack2 pane1 panels2 True True
|
||
|
||
strokesPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||
brushesPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||
transformPanel <- GTK.boxNew GTK.OrientationVertical 0
|
||
|
||
strokesTab <- GTK.labelNew ( Just "Strokes" )
|
||
brushesTab <- GTK.labelNew ( Just "Brushes" )
|
||
transformTab <- GTK.labelNew ( Just "Transform" )
|
||
|
||
for_ [ strokesTab, brushesTab, transformTab ] \ tab -> do
|
||
widgetAddClasses tab [ "plain", "text", "panelTab" ]
|
||
|
||
for_ [ strokesPanel, brushesPanel, transformPanel ] \ panel -> do
|
||
widgetAddClass panel "panel"
|
||
|
||
void $ GTK.notebookAppendPage panels1 strokesPanel ( Just strokesTab )
|
||
void $ GTK.notebookAppendPage panels1 brushesPanel ( Just brushesTab )
|
||
|
||
void $ GTK.notebookAppendPage panels2 transformPanel ( Just transformTab )
|
||
|
||
GTK.notebookSetTabReorderable panels1 strokesPanel True
|
||
GTK.notebookSetTabDetachable panels1 strokesPanel True
|
||
GTK.notebookSetTabReorderable panels1 brushesPanel True
|
||
GTK.notebookSetTabDetachable panels1 brushesPanel True
|
||
|
||
GTK.notebookSetTabReorderable panels2 transformPanel True
|
||
GTK.notebookSetTabDetachable panels2 transformPanel True
|
||
|
||
strokesContent <- GTK.labelNew ( Just "Strokes tab content..." )
|
||
brushesContent <- GTK.labelNew ( Just "Brushes tab content..." )
|
||
transformContent <- GTK.labelNew ( Just "Transform tab content..." )
|
||
|
||
GTK.boxPackStart strokesPanel strokesContent True True 0
|
||
GTK.boxPackStart brushesPanel brushesContent True True 0
|
||
GTK.boxPackStart transformPanel transformContent True True 0
|
||
|
||
---------------------------------------------------------
|
||
-- Info bar
|
||
|
||
widgetAddClasses infoBar [ "infoBar", "monospace", "contrast" ]
|
||
|
||
zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
topLeftPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
|
||
for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do
|
||
GTK.boxPackEnd infoBar box False False 0
|
||
widgetAddClass box "infoBarBox"
|
||
|
||
-------------
|
||
-- Magnifier
|
||
|
||
magnifierArea <- GTK.drawingAreaNew
|
||
zoomText <- GTK.labelNew ( Just "300%" )
|
||
|
||
GTK.boxPackStart zoomBox magnifierArea True True 0
|
||
GTK.boxPackStart zoomBox zoomText True True 0
|
||
|
||
void $ GTK.onWidgetDraw magnifierArea \ctx ->
|
||
( `Cairo.renderWithContext` ctx ) $ do
|
||
Cairo.scale 0.9 0.9
|
||
Cairo.translate 14 10
|
||
drawMagnifier colours
|
||
|
||
-------------------
|
||
-- Cursor position
|
||
|
||
cursorPosArea <- GTK.drawingAreaNew
|
||
cursorPosText <- GTK.labelNew ( Just "x: 212.12 px\ny: 120.23 px" )
|
||
|
||
GTK.boxPackStart cursorPosBox cursorPosArea False False 0
|
||
GTK.boxPackStart cursorPosBox cursorPosText False False 0
|
||
|
||
void $ GTK.onWidgetDraw cursorPosArea \ctx ->
|
||
( `Cairo.renderWithContext` ctx ) $ do
|
||
Cairo.scale 0.75 0.75
|
||
Cairo.translate 10 7
|
||
drawCursorIcon colours
|
||
|
||
---------------------
|
||
-- Top left position
|
||
|
||
topLeftPosArea <- GTK.drawingAreaNew
|
||
topLeftPosText <- GTK.labelNew ( Just "x: 212.12 px\ny: 120.23 px" )
|
||
|
||
GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0
|
||
GTK.boxPackStart topLeftPosBox topLeftPosText False False 0
|
||
|
||
void $ GTK.onWidgetDraw topLeftPosArea
|
||
$ Cairo.renderWithContext
|
||
( drawTopLeftCornerRect colours )
|
||
|
||
-------------------------
|
||
-- Bottom right position
|
||
|
||
botRightPosArea <- GTK.drawingAreaNew
|
||
botRightPosText <- GTK.labelNew ( Just "x: 212.12 px\ny: 120.23 px" )
|
||
|
||
GTK.boxPackStart botRightPosBox botRightPosArea False False 0
|
||
GTK.boxPackStart botRightPosBox botRightPosText False False 0
|
||
|
||
void $ GTK.onWidgetDraw botRightPosArea \ctx ->
|
||
( `Cairo.renderWithContext` ctx ) $ do
|
||
Cairo.scale -1 -1
|
||
Cairo.translate -40 -40
|
||
drawTopLeftCornerRect colours
|
||
|
||
-------------------------
|
||
|
||
for_ [ magnifierArea, cursorPosArea, topLeftPosArea, botRightPosArea ] \ area -> do
|
||
widgetAddClass area "infoBarIcon"
|
||
GTK.widgetSetSizeRequest area 40 40 -- not sure why this is needed...?
|
||
|
||
for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do
|
||
widgetAddClass info "infoBarInfo"
|
||
|
||
---------------------------------------------------------
|
||
-- Actions
|
||
|
||
GTK.widgetAddEvents window
|
||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
||
GTK.widgetAddEvents viewportArea
|
||
[ GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask ]
|
||
|
||
_ <- GTK.onButtonClicked closeButton GTK.mainQuit
|
||
_ <- 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.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
|
||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||
|
||
---------------------------------------------------------
|
||
-- GTK main loop
|
||
|
||
GTK.widgetShowAll window
|
||
GTK.main
|
||
|
||
exitSuccess
|
||
|
||
---------------------------------------------------------
|
||
-- Utils.
|
||
|
||
data Exists c where
|
||
Exists :: c a => a -> Exists c
|