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

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

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

-- base
import Data.Foldable
  ( for_ )

-- gi-gdk
import qualified GI.Gdk as GDK

-- gi-gtk
import qualified GI.Gtk as GTK

-- MetaBrush
import MetaBrush.Util
  ( widgetAddClass )

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

data Viewport
  = Viewport
  {    viewportDrawingArea
  , rulerCornerDrawingArea
  ,   leftRulerDrawingArea
  ,    topRulerDrawingArea
    :: !GTK.DrawingArea
  }

createViewport :: GTK.Grid -> IO Viewport
createViewport 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

  rulerCornerDrawingArea <- GTK.drawingAreaNew
  GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0

  leftRulerDrawingArea   <- GTK.drawingAreaNew
  GTK.boxPackStart leftRuler   leftRulerDrawingArea   True True 0
  
  topRulerDrawingArea    <- GTK.drawingAreaNew
  GTK.boxPackStart topRuler    topRulerDrawingArea    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

  for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do
    GTK.widgetAddEvents drawingArea
      [ 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"

  -}

  pure ( Viewport {..} )

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

data Ruler
  = RulerCorner
  | LeftRuler
  | TopRuler
  deriving stock Show