metabrush/src/app/MetaBrush/Context.hs

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

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

-- base
import Control.Monad
  ( join )
import Data.Foldable
  ( for_, sequenceA_ )
import Data.Traversable
  ( 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 as STM
  ( atomically )
import qualified Control.Concurrent.STM.TVar as STM
  ( TVar, readTVar, readTVar, writeTVar )

-- text
import Data.Text
  ( Text )

-- 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
  , titleBar            :: !GTK.Box
  , 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 )        )
  , fileBarTabsTVar    :: !( STM.TVar ( Map Unique GTK.Box )       )
  }

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

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 :: UIElements -> Variables -> ( Document -> STM ( Maybe Document ) ) -> IO ()
modifyingCurrentDocument ( UIElements { .. } ) ( Variables { .. } ) f = do
  mbActions <- STM.atomically do
    mbUnique <- STM.readTVar activeDocumentTVar
    for mbUnique \ unique -> do
      docs <- STM.readTVar openDocumentsTVar
      mbUpdateTitleAction <-
        join <$> for ( Map.lookup unique docs ) \ oldDoc -> do
          mbNewDoc <- f oldDoc
          for mbNewDoc \ newDoc -> do
            STM.writeTVar openDocumentsTVar ( Map.insert unique newDoc docs )
            pure do
              updateTitle window title $ Just ( displayName newDoc, unsavedChanges newDoc )
              GTK.widgetQueueDraw viewportDrawingArea
      mbActiveTab <- Map.lookup unique <$> STM.readTVar fileBarTabsTVar
      pure ( for_ mbActiveTab GTK.widgetQueueDraw *> sequenceA_ mbUpdateTitleAction )
  sequenceA_ mbActions

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"