2020-08-10 22:07:09 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
|
|
|
|
|
|
module MetaBrush.UI.Viewport
|
|
|
|
|
( Viewport(..), createViewport )
|
|
|
|
|
where
|
|
|
|
|
|
|
|
|
|
-- gi-gdk
|
|
|
|
|
import qualified GI.Gdk as GDK
|
|
|
|
|
|
|
|
|
|
-- gi-gtk
|
|
|
|
|
import qualified GI.Gtk as GTK
|
|
|
|
|
|
|
|
|
|
-- MetaBrush
|
2020-09-01 19:56:59 +00:00
|
|
|
import MetaBrush.Util
|
2020-08-10 22:07:09 +00:00
|
|
|
( widgetAddClass )
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
|
|
|
|
|
data Viewport
|
|
|
|
|
= Viewport
|
|
|
|
|
{ viewportDrawingArea :: !GTK.DrawingArea
|
|
|
|
|
}
|
|
|
|
|
|
2020-08-15 21:49:14 +00:00
|
|
|
createViewport :: GTK.Grid -> IO Viewport
|
|
|
|
|
createViewport viewportGrid = do
|
2020-08-10 22:07:09 +00:00
|
|
|
|
|
|
|
|
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
|
2020-08-12 21:23:19 +00:00
|
|
|
, GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
|
2020-08-10 22:07:09 +00:00
|
|
|
, 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 { .. } )
|
