mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
134 lines
4.1 KiB
Haskell
134 lines
4.1 KiB
Haskell
{-# 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
|