metabrush/src/app/MetaBrush/Context.hs

{-# LANGUAGE BlockArguments     #-}
{-# LANGUAGE ConstraintKinds    #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE TypeApplications   #-}

module MetaBrush.Context
  ( UIElements(..), Variables(..)
  , LR(..), Modifier(..), modifierKey, modifierType
  , HoldAction(..), 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 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
  , 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 )       )
  }

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

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

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 { .. } ) 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_ 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"