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