mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
257 lines
8.2 KiB
Haskell
257 lines
8.2 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
||
{-# LANGUAGE ConstraintKinds #-}
|
||
{-# LANGUAGE DataKinds #-}
|
||
{-# LANGUAGE DerivingStrategies #-}
|
||
{-# LANGUAGE FlexibleContexts #-}
|
||
{-# LANGUAGE LambdaCase #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE RecordWildCards #-}
|
||
{-# LANGUAGE NamedFieldPuns #-}
|
||
|
||
module MetaBrush.Context
|
||
( UIElements(..), Variables(..)
|
||
, LR(..), Modifier(..), modifierKey, modifierType
|
||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||
, currentDocument, withCurrentDocument
|
||
, PureDocModification(..), DocModification(..)
|
||
, modifyingCurrentDocument
|
||
, updateTitle
|
||
)
|
||
where
|
||
|
||
-- base
|
||
import Data.Foldable
|
||
( for_, sequenceA_ )
|
||
import Data.Word
|
||
( Word32 )
|
||
|
||
-- containers
|
||
import Data.Set
|
||
( Set )
|
||
import Data.Map.Strict
|
||
( Map )
|
||
import qualified Data.Map.Strict as Map
|
||
( insert, lookup, delete )
|
||
|
||
-- gi-gtk
|
||
import qualified GI.Gdk as GDK
|
||
|
||
-- gi-gtk
|
||
import qualified GI.Gtk as GTK
|
||
|
||
-- lens
|
||
import Control.Lens.Fold
|
||
( Fold, forOf_, sequenceAOf_ )
|
||
|
||
-- stm
|
||
import Control.Concurrent.STM
|
||
( STM )
|
||
import qualified Control.Concurrent.STM as STM
|
||
( atomically )
|
||
import qualified Control.Concurrent.STM.TVar as STM
|
||
( TVar, readTVar, readTVar, modifyTVar' )
|
||
|
||
-- text
|
||
import Data.Text
|
||
( Text )
|
||
|
||
-- transformers
|
||
import Control.Monad.Trans.Class
|
||
( lift )
|
||
import Control.Monad.Trans.Maybe
|
||
( MaybeT(..) )
|
||
|
||
-- MetaBrush
|
||
import Math.Vector2D
|
||
( Point2D )
|
||
import MetaBrush.Asset.Colours
|
||
( Colours )
|
||
import MetaBrush.Document
|
||
( Document(..) )
|
||
import MetaBrush.Document.Draw
|
||
( DrawAnchor )
|
||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||
( FileBar, removeFileTab )
|
||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||
( InfoBar, updateInfoBar )
|
||
import {-# SOURCE #-} MetaBrush.UI.Menu
|
||
( Menu, ResourceType(Object) )
|
||
import MetaBrush.UI.ToolBar
|
||
( Tool, Mode )
|
||
import MetaBrush.UI.Viewport
|
||
( Viewport(..), Ruler(..) )
|
||
import MetaBrush.Unique
|
||
( UniqueSupply, Unique )
|
||
import MetaBrush.Util
|
||
( (>>?=) )
|
||
|
||
--------------------------------------------------------------------------------
|
||
|
||
data UIElements
|
||
= UIElements
|
||
{ window :: !GTK.Window
|
||
, title :: !GTK.Label
|
||
, titleBar :: !GTK.Box
|
||
, fileBar :: !FileBar
|
||
, viewport :: !Viewport
|
||
, infoBar :: !InfoBar
|
||
, menu :: Menu Object -- needs to be lazy for "recursive do"
|
||
, colours :: !Colours
|
||
}
|
||
|
||
data Variables
|
||
= Variables
|
||
{ uniqueSupply :: !UniqueSupply
|
||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||
, openDocumentsTVar :: !( STM.TVar ( Map Unique Document ) )
|
||
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
|
||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||
, toolTVar :: !( STM.TVar Tool )
|
||
, modeTVar :: !( STM.TVar Mode )
|
||
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
|
||
, fileBarTabsTVar :: !( STM.TVar ( Map Unique GTK.Box ) )
|
||
, showGuidesTVar :: !( STM.TVar Bool )
|
||
}
|
||
|
||
--------------------------------------------------------------------------------
|
||
|
||
data LR = L | R
|
||
deriving stock ( Show, Eq, Ord )
|
||
|
||
data Modifier
|
||
= Control LR
|
||
| Alt LR
|
||
| Shift LR
|
||
deriving stock ( Show, Eq, Ord )
|
||
|
||
modifierKey :: Word32 -> Maybe Modifier
|
||
modifierKey GDK.KEY_Control_L = Just ( Control L )
|
||
modifierKey GDK.KEY_Control_R = Just ( Control R )
|
||
modifierKey GDK.KEY_Shift_L = Just ( Shift L )
|
||
modifierKey GDK.KEY_Shift_R = Just ( Shift R )
|
||
modifierKey GDK.KEY_Alt_L = Just ( Alt L )
|
||
modifierKey GDK.KEY_Alt_R = Just ( Alt R )
|
||
modifierKey _ = Nothing
|
||
|
||
modifierType :: Modifier -> GDK.ModifierType
|
||
modifierType ( Control _ ) = GDK.ModifierTypeControlMask
|
||
modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask
|
||
modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask
|
||
|
||
|
||
data GuideAction
|
||
= CreateGuide !Ruler
|
||
| MoveGuide !Unique
|
||
deriving stock Show
|
||
|
||
-- | Keep track of a mouse hold action:
|
||
--
|
||
-- - start a rectangular selection,
|
||
-- - move objects by dragging,
|
||
-- - drawing a control point,
|
||
-- - create/modify a guide.
|
||
data HoldAction
|
||
= SelectionHold { holdStartPos :: !( Point2D Double ) }
|
||
| DragMoveHold { holdStartPos :: !( Point2D Double ) }
|
||
| DrawHold { holdStartPos :: !( Point2D Double ) }
|
||
| GuideAction { holdStartPos :: !( Point2D Double )
|
||
, guideAction :: !GuideAction
|
||
}
|
||
deriving stock Show
|
||
|
||
-- | Keep track of a path that is in the middle of being drawn.
|
||
data PartialPath
|
||
= PartialPath
|
||
{ partialStartPos :: !( Point2D Double )
|
||
, partialControlPoint :: !( Maybe ( Point2D Double ) )
|
||
, partialPathAnchor :: !DrawAnchor
|
||
, firstPoint :: !Bool
|
||
}
|
||
deriving stock Show
|
||
|
||
--------------------------------------------------------------------------------
|
||
|
||
-- | Read the currently active document from the stateful variables.
|
||
currentDocument :: Variables -> STM ( Maybe Document )
|
||
currentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } )
|
||
= STM.readTVar activeDocumentTVar
|
||
>>?= ( \ unique -> Map.lookup unique <$> STM.readTVar openDocumentsTVar )
|
||
|
||
-- | Do something with the currently active document.
|
||
--
|
||
-- Does nothing if no document is currently active.
|
||
withCurrentDocument :: Variables -> ( Document -> STM a ) -> STM ( Maybe a )
|
||
withCurrentDocument vars f = traverse f =<< currentDocument vars
|
||
|
||
data PureDocModification
|
||
= Don'tModifyDoc
|
||
| UpdateDocTo ( Maybe Document )
|
||
|
||
data DocModification
|
||
= Don'tModifyDocAndThen { postModifAction :: IO () }
|
||
| UpdateDocToAndThen
|
||
{ modifDocument :: ( Maybe Document )
|
||
, postModifAction :: IO ()
|
||
}
|
||
|
||
class DocumentModification modif where
|
||
docFold :: Fold modif ( Maybe Document )
|
||
actionFold :: Fold modif ( IO () )
|
||
|
||
instance DocumentModification PureDocModification where
|
||
docFold _ Don'tModifyDoc = pure Don'tModifyDoc
|
||
docFold f ( UpdateDocTo mbDoc ) = UpdateDocTo <$> ( f mbDoc )
|
||
actionFold _ a = pure a
|
||
|
||
instance DocumentModification DocModification where
|
||
docFold _ don't@( Don'tModifyDocAndThen {} ) = pure don't
|
||
docFold f ( UpdateDocToAndThen mbDoc action ) = ( \ mbDoc' -> UpdateDocToAndThen mbDoc' action ) <$> f mbDoc
|
||
actionFold f modif = ( \ action' -> modif { postModifAction = action' } ) <$> f ( postModifAction modif )
|
||
|
||
-- | Modify the currently active document.
|
||
--
|
||
-- Does nothing if no document is currently active.
|
||
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
|
||
modifyingCurrentDocument ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do
|
||
mbAction <- STM.atomically . runMaybeT $ do
|
||
unique <- MaybeT ( STM.readTVar activeDocumentTVar )
|
||
oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar )
|
||
modif <- lift ( f oldDoc )
|
||
forOf_ docFold modif \case
|
||
Nothing
|
||
-> lift ( STM.modifyTVar' openDocumentsTVar ( Map.delete unique ) )
|
||
Just newDoc
|
||
-> lift ( STM.modifyTVar' openDocumentsTVar ( Map.insert unique newDoc ) )
|
||
mbActiveTab <- lift ( Map.lookup unique <$> STM.readTVar fileBarTabsTVar )
|
||
pure
|
||
do
|
||
forOf_ docFold modif \ mbNewDoc -> do
|
||
case mbNewDoc of
|
||
Nothing -> do
|
||
removeFileTab vars ( documentUnique oldDoc )
|
||
updateTitle window title Nothing
|
||
updateInfoBar viewportDrawingArea infoBar vars
|
||
Just ( Document { displayName, unsavedChanges } ) -> do
|
||
updateTitle window title ( Just ( displayName, unsavedChanges ) )
|
||
GTK.widgetQueueDraw viewportDrawingArea
|
||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||
GTK.widgetQueueDraw drawingArea
|
||
for_ mbActiveTab GTK.widgetQueueDraw
|
||
sequenceAOf_ actionFold modif
|
||
sequenceA_ mbAction
|
||
|
||
updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
|
||
updateTitle window title mbTitleText = do
|
||
GTK.labelSetText title titleText
|
||
GTK.setWindowTitle window titleText
|
||
where
|
||
titleText :: Text
|
||
titleText = case mbTitleText of
|
||
Nothing -> "MetaBrush"
|
||
Just ( name, hasUnsavedChanges )
|
||
| hasUnsavedChanges
|
||
-> "● " <> name <> " – MetaBrush"
|
||
| otherwise
|
||
-> name <> " – MetaBrush"
|