metabrush/app/Main.hs

{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NegativeLiterals  #-}
{-# 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-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

-- text
import qualified Data.Text as Text
  ( pack )

-- MetaBrush
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.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 <- 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
  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"

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

  ---------------------------------------------------------
  -- 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
      isActive <- GTK.toggleButtonGetActive pgButton
      flags  <- GTK.widgetGetStateFlags tab
      if isActive
      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"
  
  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

  viewportArea <- GTK.drawingAreaNew
  GTK.setContainerChild viewportOverlay viewportArea

  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

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