mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
315 lines
10 KiB
Haskell
315 lines
10 KiB
Haskell
{-# 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.Colours
|
||
( ColourRecord(..), colours )
|
||
import MetaBrush.Asset.Logo
|
||
( drawLogo )
|
||
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 ]
|
||
|
||
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 3 1
|
||
GTK.gridAttach uiGrid toolBar 0 2 2 2
|
||
GTK.gridAttach uiGrid mainPane 2 1 2 4
|
||
|
||
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
|
||
|
||
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 )
|
||
|
||
---------------------------------------------------------
|
||
-- Tool bar
|
||
|
||
widgetAddClass toolBar "toolBar"
|
||
|
||
---------------------------------------------------------
|
||
-- File bar
|
||
|
||
widgetAddClass fileBar "fileBar"
|
||
|
||
fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
|
||
GTK.containerAdd fileBar fileTabs
|
||
widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
|
||
|
||
phantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||
|
||
for_ [ 1 .. 12 ] \ i -> do
|
||
-- File tab elements.
|
||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just phantomRadioButton ) ( "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" ]
|
||
|
||
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 main loop
|
||
|
||
GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask]
|
||
_ <- GTK.onWidgetKeyPressEvent window handleKeyboardPressEvent
|
||
_ <- GTK.onWidgetKeyReleaseEvent window handleKeyboardReleaseEvent
|
||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||
|
||
GTK.widgetShowAll window
|
||
GTK.main
|
||
|
||
exitSuccess
|
||
|
||
|
||
data Exists c where
|
||
Exists :: c a => a -> Exists c |