metabrush/app/Main.hs

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