metabrush/src/app/MetaBrush/UI/Viewport.hs

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

module MetaBrush.UI.Viewport
  ( Viewport(..), createViewport )
  where

-- base
import Control.Monad
  ( void )
import Data.Foldable
  ( for_ )

-- containers
import Data.IntMap.Strict
  ( IntMap )

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

-- stm
import qualified Control.Concurrent.STM.TVar as STM
  ( TVar, readTVarIO )

-- MetaBrush
import MetaBrush.Asset.Colours
  ( Colours )
import MetaBrush.Document
  ( Document(..), currentDocument
  , Overlay
  )
import MetaBrush.Render.Document
  ( renderDocument )
import MetaBrush.Render.Util
  ( widgetAddClass )

--------------------------------------------------------------------------------

data Viewport
  = Viewport
  { viewportDrawingArea :: !GTK.DrawingArea
  }

createViewport
  :: Colours
  -> STM.TVar ( Maybe Int )
  -> STM.TVar ( IntMap Document )
  -> STM.TVar ( Maybe Overlay )
  -> GTK.Grid
  -> IO Viewport
createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
  
  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

  ----------
  -- Rulers

  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

  viewportDrawingArea <- GTK.drawingAreaNew
  GTK.setContainerChild viewportOverlay viewportDrawingArea
  GTK.widgetAddEvents viewportDrawingArea
    [ GDK.EventMaskPointerMotionMask
    , GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
    , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask
    ]

  -----------------
  -- Viewport scrolling

  viewportScrollbarGrid <- GTK.gridNew
  GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid
  GTK.overlaySetOverlayPassThrough viewportOverlay viewportScrollbarGrid True

  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"

  -----------------
  -- Rendering

  void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do
    -- Get the relevant document information
    mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
    mbOverlay <- STM.readTVarIO overlayTVar
    for_ mbDoc \ doc -> do
      ( `Cairo.renderWithContext` ctx ) $ do
        viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
        viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
        renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
    pure True

  pure ( Viewport { .. } )