metabrush/src/app/MetaBrush/Context.hs

{-# LANGUAGE BlockArguments     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns     #-}

module MetaBrush.Context
  ( UIElements(..), Variables(..)
  , LR(..), Modifier(..), modifierKey, modifierType
  , HoldAction(..), PartialPath(..)
  , currentDocument, withCurrentDocument, modifyingCurrentDocument
  )
  where

-- base
import Data.Foldable
  ( for_ )
import Data.Word
  ( Word32 )

-- containers
import Data.Set
  ( Set )
import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( insert, lookup )

-- gi-gtk
import qualified GI.Gdk as GDK

-- gi-gtk
import qualified GI.Gtk as GTK

-- stm
import Control.Concurrent.STM
  ( STM )
import qualified Control.Concurrent.STM.TVar as STM
  ( TVar, readTVar, readTVar, writeTVar )

-- MetaBrush
import Math.Vector2D
  ( Point2D )
import MetaBrush.Document
  ( Document )
import MetaBrush.Document.Draw
  ( DrawAnchor )
import {-# SOURCE #-} MetaBrush.UI.FileBar
  ( FileBar )
import {-# SOURCE #-} MetaBrush.UI.InfoBar
  ( InfoBar )
import MetaBrush.UI.ToolBar
  ( Tool, Mode )
import MetaBrush.Unique
  ( UniqueSupply, Unique )
import MetaBrush.Util
  ( (>>?=) )

--------------------------------------------------------------------------------

data UIElements
  = UIElements
  { window              :: !GTK.Window
  , title               :: !GTK.Label
  , fileBar             :: !FileBar
  , viewportDrawingArea :: !GTK.DrawingArea
  , infoBar             :: !InfoBar
  }

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 )        )
  }

--------------------------------------------------------------------------------

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

-- | Keep track of a mouse hold action:
--
--  - start a rectangular selection,
--  - move objects by dragging,
--  - drawing a control point.
data HoldAction
  = SelectionHold { holdStartPos :: !( Point2D Double ) }
  | DragMoveHold  { holdStartPos :: !( Point2D Double ) }
  | DrawHold      { holdStartPos :: !( Point2D Double ) }
  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

-- | Modify the currently active document.
--
-- Does nothing if no document is currently active.
modifyingCurrentDocument :: Variables -> ( Document -> STM ( Maybe Document ) ) -> STM ()
modifyingCurrentDocument ( Variables { activeDocumentTVar, openDocumentsTVar } ) f = do
  mbUnique <- STM.readTVar activeDocumentTVar
  case mbUnique of
    Nothing -> pure ()
    Just unique -> do
      docs <- STM.readTVar openDocumentsTVar
      for_ ( Map.lookup unique docs ) \ oldDoc -> do
        mbNewDoc <- f oldDoc
        for_ mbNewDoc \ newDoc -> do
          STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )