{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Main ( main ) where -- base import Control.Monad ( void ) import Data.Foldable ( for_ ) import Data.Int ( Int32 ) import System.Exit ( exitSuccess ) -- directory import qualified System.Directory as Directory ( canonicalizePath ) -- gi-cairo-connector import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) -- gi-gdk import qualified GI.Gdk as GDK -- gi-gtk import qualified GI.Gtk as GTK -- text import qualified Data.Text as Text ( pack ) -- MetaBrush import MetaBrush.Asset.Brush ( drawBrush ) import MetaBrush.Asset.Colours ( ColourRecord(..), colours ) import MetaBrush.Asset.Cursor ( drawCursorIcon ) import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Asset.Meta ( drawMeta ) import MetaBrush.Asset.WindowIcons ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) import MetaBrush.Event ( handleKeyboardPressEvent, handleKeyboardReleaseEvent ) import MetaBrush.Render.Util ( widgetAddClass, widgetAddClasses ) import MetaBrush.UI.Menu ( newMenuBar ) import qualified Paths_MetaBrush as Cabal ( getDataFileName ) -------------------------------------------------------------------------------- main :: IO () main = do --------------------------------------------------------- -- 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 True 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 { .. } <- colours 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 panelGrid <- GTK.gridNew 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 panelGrid 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" --------------------------------------------------------- -- Logo widgetAddClass logo "logo" logoArea <- GTK.drawingAreaNew GTK.boxPackStart logo logoArea True True 0 void $ GTK.onWidgetDraw logoArea $ Cairo.renderWithContext ( drawLogo logo_base logo_highlight logo_base ) --------------------------------------------------------- -- Title bar widgetAddClass titleBar "titleBar" ( 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 plain ) 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 plain ) cairoContext else Cairo.renderWithContext ( drawMaximise plain ) cairoContext void $ GTK.onWidgetDraw closeArea $ Cairo.renderWithContext ( drawClose plain ) 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 toolBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) selectionTool <- GTK.radioButtonNewFromWidget ( Just toolBarPhantomRadioButton ) brushTool <- GTK.radioButtonNewFromWidget ( Just toolBarPhantomRadioButton ) metaTool <- GTK.radioButtonNewFromWidget ( Just toolBarPhantomRadioButton ) GTK.boxPackStart toolBar selectionTool True True 0 GTK.boxPackStart toolBar brushTool True True 0 GTK.boxPackStart toolBar metaTool True True 0 for_ [ selectionTool, brushTool, metaTool ] \ tool -> do GTK.toggleButtonSetMode tool False -- don't display radio indicator widgetAddClass tool "toolItem" selectionToolArea <- GTK.drawingAreaNew brushToolArea <- GTK.drawingAreaNew metaToolArea <- GTK.drawingAreaNew {- for_ [ selectionToolArea, brushToolArea, metaToolArea ] \ toolArea -> do GTK.widgetSetValign toolArea GTK.AlignCenter GTK.widgetSetHalign toolArea GTK.AlignCenter -} GTK.containerAdd selectionTool selectionToolArea GTK.containerAdd brushTool brushToolArea GTK.containerAdd metaTool metaToolArea void $ GTK.onWidgetDraw selectionToolArea $ Cairo.renderWithContext ( drawCursorIcon logo_base ) void $ GTK.onWidgetDraw brushToolArea $ Cairo.renderWithContext ( drawBrush logo_base logo_highlight logo_base ) void $ GTK.onWidgetDraw metaToolArea $ Cairo.renderWithContext ( drawMeta logo_highlight ) --------------------------------------------------------- -- 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 ) for_ [ 1 .. 12 ] \ i -> do -- File tab elements. pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( "New Document (" <> Text.pack ( show i ) <> ")" ) 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 active <- GTK.toggleButtonGetActive pgButton flags <- GTK.widgetGetStateFlags tab if active then GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True 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 GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever GTK.scrolledWindowSetOverlayScrolling fileBar True --------------------------------------------------------- -- Main viewport widgetAddClass viewportGrid "viewport_bg" 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 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 viewport <- GTK.drawingAreaNew GTK.setContainerChild viewportOverlay viewport viewportScrollbarGrid <- GTK.gridNew GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid 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" --------------------------------------------------------- -- Panels widgetAddClass panelGrid "panels" --------------------------------------------------------- -- Info bar widgetAddClass infoBar "infoBar" --------------------------------------------------------- -- Actions GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask] _ <- 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 _ <- GTK.onWidgetKeyReleaseEvent window handleKeyboardReleaseEvent _ <- GTK.onWidgetDestroy window GTK.mainQuit --------------------------------------------------------- -- GTK main loop GTK.widgetShowAll window GTK.main exitSuccess data Exists c where Exists :: c a => a -> Exists c