mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
152 lines
4.7 KiB
Haskell
152 lines
4.7 KiB
Haskell
{-# 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 )
|
|
|
|
-- MetaBrush
|
|
import MetaBrush.Asset.Colours
|
|
( Colours )
|
|
import MetaBrush.Document
|
|
( Document(..), currentDocument )
|
|
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 )
|
|
-> GTK.Grid
|
|
-> IO Viewport
|
|
createViewport colours activeDocumentTVar openDocumentsTVar 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.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
|
|
for_ mbDoc \ doc -> do
|
|
( `Cairo.renderWithContext` ctx ) $ do
|
|
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
|
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
|
renderDocument colours ( viewportWidth, viewportHeight ) doc
|
|
pure True
|
|
|
|
pure ( Viewport { .. } )
|