metabrush/app/Main.hs

{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

module Main
  ( main )
  where

-- base
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

  _ <- 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

  _ <- 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"

  ---------------------------------------------------------
  -- Main viewport

  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
    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just phantomRadioButton ) ( "● New Document (" <> Text.pack ( show i ) <> ")" )
    GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
    widgetAddClasses pgButton [ "fileBarTab" ]
    GTK.boxPackStart fileTabs pgButton False False 0

  GTK.scrolledWindowSetPolicy           fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
  GTK.scrolledWindowSetOverlayScrolling fileBar True

  widgetAddClass viewportGrid "viewport_bg"
  
  rvRulerCorner <- GTK.revealerNew
  rvLeftRuler   <- GTK.revealerNew
  rvTopRuler    <- GTK.revealerNew
  viewport      <- GTK.drawingAreaNew

  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 viewport      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 viewport    True
  GTK.widgetSetVexpand viewport    True

  ---------------------------------------------------------
  -- 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