{-|
Module      : Monomer.Main.Util
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Helper functions for the Main module.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Strict #-}

module Monomer.Main.Util where

import Control.Applicative ((<|>))
import Control.Concurrent.STM.TChan
import Control.Lens ((&), (^.), (.=), (%=), ix, at, non, use, _1)
import Control.Monad.Extra
import Control.Monad.State
import Data.Default
import Data.Maybe

import qualified Data.Sequence as Seq
import qualified Data.Map as Map
import qualified SDL

import Monomer.Core
import Monomer.Event
import Monomer.Helper (headMay)
import Monomer.Main.Platform
import Monomer.Main.Types
import Monomer.Widgets.Util.Widget

import qualified Monomer.Core.Lens as L
import qualified Monomer.Main.Lens as L

-- | Initializes the Monomer context with the provided information.
initMonomerCtx
  :: SDL.Window
  -> TChan (RenderMsg s e)
  -> Size
  -> Double
  -> Double
  -> s
  -> MonomerCtx s e
initMonomerCtx :: Window
-> TChan (RenderMsg s e)
-> Size
-> Double
-> Double
-> s
-> MonomerCtx s e
initMonomerCtx ~Window
win TChan (RenderMsg s e)
channel Size
winSize Double
dpr Double
epr s
model = MonomerCtx :: forall s e.
s
-> Window
-> Size
-> Double
-> Double
-> Either Renderer (TChan (RenderMsg s e))
-> InputStatus
-> [(WidgetId, CursorIcon)]
-> WidgetId
-> Maybe WidgetId
-> Maybe WidgetId
-> Maybe DragAction
-> Maybe (Path, Point)
-> Seq WidgetTask
-> Map WidgetId Path
-> Map CursorIcon Cursor
-> Bool
-> Seq WidgetId
-> Bool
-> Map WidgetId RenderSchedule
-> Bool
-> MonomerCtx s e
MonomerCtx {
  _mcMainModel :: s
_mcMainModel = s
model,
  _mcWindow :: Window
_mcWindow = Window
win,
  _mcWindowSize :: Size
_mcWindowSize = Size
winSize,
  _mcDpr :: Double
_mcDpr = Double
dpr,
  _mcEpr :: Double
_mcEpr = Double
epr,
  _mcRenderMethod :: Either Renderer (TChan (RenderMsg s e))
_mcRenderMethod = TChan (RenderMsg s e) -> Either Renderer (TChan (RenderMsg s e))
forall a b. b -> Either a b
Right TChan (RenderMsg s e)
channel,
  _mcInputStatus :: InputStatus
_mcInputStatus = InputStatus
forall a. Default a => a
def,
  _mcCursorStack :: [(WidgetId, CursorIcon)]
_mcCursorStack = [],
  _mcFocusedWidgetId :: WidgetId
_mcFocusedWidgetId = WidgetId
forall a. Default a => a
def,
  _mcHoveredWidgetId :: Maybe WidgetId
_mcHoveredWidgetId = Maybe WidgetId
forall a. Maybe a
Nothing,
  _mcOverlayWidgetId :: Maybe WidgetId
_mcOverlayWidgetId = Maybe WidgetId
forall a. Maybe a
Nothing,
  _mcDragAction :: Maybe DragAction
_mcDragAction = Maybe DragAction
forall a. Maybe a
Nothing,
  _mcMainBtnPress :: Maybe (Path, Point)
_mcMainBtnPress = Maybe (Path, Point)
forall a. Maybe a
Nothing,
  _mcWidgetTasks :: Seq WidgetTask
_mcWidgetTasks = Seq WidgetTask
forall a. Seq a
Seq.empty,
  _mcWidgetPaths :: Map WidgetId Path
_mcWidgetPaths = Map WidgetId Path
forall k a. Map k a
Map.empty,
  _mcCursorIcons :: Map CursorIcon Cursor
_mcCursorIcons = Map CursorIcon Cursor
forall k a. Map k a
Map.empty,
  _mcLeaveEnterPair :: Bool
_mcLeaveEnterPair = Bool
False,
  _mcResizeRequests :: Seq WidgetId
_mcResizeRequests = Seq WidgetId
forall a. Seq a
Seq.empty,
  _mcRenderRequested :: Bool
_mcRenderRequested = Bool
False,
  _mcRenderSchedule :: Map WidgetId RenderSchedule
_mcRenderSchedule = Map WidgetId RenderSchedule
forall k a. Map k a
Map.empty,
  _mcExitApplication :: Bool
_mcExitApplication = Bool
False
}

-- | Returns the path of the provided "WidgetId".
getWidgetIdPath :: (MonomerM s e m) => WidgetId -> m Path
getWidgetIdPath :: WidgetId -> m Path
getWidgetIdPath WidgetId
widgetId =
  Getting Path (MonomerCtx s e) Path -> m Path
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Getting Path (MonomerCtx s e) Path -> m Path)
-> Getting Path (MonomerCtx s e) Path -> m Path
forall a b. (a -> b) -> a -> b
$ (Map WidgetId Path -> Const Path (Map WidgetId Path))
-> MonomerCtx s e -> Const Path (MonomerCtx s e)
forall s a. HasWidgetPaths s a => Lens' s a
L.widgetPaths ((Map WidgetId Path -> Const Path (Map WidgetId Path))
 -> MonomerCtx s e -> Const Path (MonomerCtx s e))
-> ((Path -> Const Path Path)
    -> Map WidgetId Path -> Const Path (Map WidgetId Path))
-> Getting Path (MonomerCtx s e) Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map WidgetId Path)
-> Lens' (Map WidgetId Path) (Maybe (IxValue (Map WidgetId Path)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map WidgetId Path)
WidgetId
widgetId ((Maybe Path -> Const Path (Maybe Path))
 -> Map WidgetId Path -> Const Path (Map WidgetId Path))
-> ((Path -> Const Path Path)
    -> Maybe Path -> Const Path (Maybe Path))
-> (Path -> Const Path Path)
-> Map WidgetId Path
-> Const Path (Map WidgetId Path)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Iso' (Maybe Path) Path
forall a. Eq a => a -> Iso' (Maybe a) a
non (WidgetId
widgetId WidgetId -> Getting Path WidgetId Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetId Path
forall s a. HasPath s a => Lens' s a
L.path)

-- | Updates the path associated to a "WidgetId".
setWidgetIdPath :: (MonomerM s e m) => WidgetId -> Path -> m ()
setWidgetIdPath :: WidgetId -> Path -> m ()
setWidgetIdPath WidgetId
widgetId Path
path = (Map WidgetId Path -> Identity (Map WidgetId Path))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasWidgetPaths s a => Lens' s a
L.widgetPaths ((Map WidgetId Path -> Identity (Map WidgetId Path))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe Path -> Identity (Maybe Path))
    -> Map WidgetId Path -> Identity (Map WidgetId Path))
-> (Maybe Path -> Identity (Maybe Path))
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map WidgetId Path)
-> Lens' (Map WidgetId Path) (Maybe (IxValue (Map WidgetId Path)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map WidgetId Path)
WidgetId
widgetId ((Maybe Path -> Identity (Maybe Path))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe Path -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Path -> Maybe Path
forall a. a -> Maybe a
Just Path
path

-- | Removes the association of a path to a "WidgetId".
delWidgetIdPath :: (MonomerM s e m) => WidgetId -> m ()
delWidgetIdPath :: WidgetId -> m ()
delWidgetIdPath WidgetId
widgetId = (Map WidgetId Path -> Identity (Map WidgetId Path))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasWidgetPaths s a => Lens' s a
L.widgetPaths ((Map WidgetId Path -> Identity (Map WidgetId Path))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe Path -> Identity (Maybe Path))
    -> Map WidgetId Path -> Identity (Map WidgetId Path))
-> (Maybe Path -> Identity (Maybe Path))
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map WidgetId Path)
-> Lens' (Map WidgetId Path) (Maybe (IxValue (Map WidgetId Path)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map WidgetId Path)
WidgetId
widgetId ((Maybe Path -> Identity (Maybe Path))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe Path -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe Path
forall a. Maybe a
Nothing

-- | Returns the path of the currently hovered node, if any.
getHoveredPath :: (MonomerM s e m) => m (Maybe Path)
getHoveredPath :: m (Maybe Path)
getHoveredPath = do
  Maybe WidgetId
hoveredWidgetId <- Getting (Maybe WidgetId) (MonomerCtx s e) (Maybe WidgetId)
-> m (Maybe WidgetId)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe WidgetId) (MonomerCtx s e) (Maybe WidgetId)
forall s a. HasHoveredWidgetId s a => Lens' s a
L.hoveredWidgetId
  case Maybe WidgetId
hoveredWidgetId of
    Just WidgetId
wid -> Path -> Maybe Path
forall a. a -> Maybe a
Just (Path -> Maybe Path) -> m Path -> m (Maybe Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
wid
    Maybe WidgetId
Nothing -> Maybe Path -> m (Maybe Path)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Path
forall a. Maybe a
Nothing

-- | Returns the path of the currently focused node.
getFocusedPath :: (MonomerM s e m) => m Path
getFocusedPath :: m Path
getFocusedPath = WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath (WidgetId -> m Path) -> m WidgetId -> m Path
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting WidgetId (MonomerCtx s e) WidgetId -> m WidgetId
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting WidgetId (MonomerCtx s e) WidgetId
forall s a. HasFocusedWidgetId s a => Lens' s a
L.focusedWidgetId

-- | Returns the path of the current overlay node, if any.
getOverlayPath :: (MonomerM s e m) => m (Maybe Path)
getOverlayPath :: m (Maybe Path)
getOverlayPath = do
  Maybe WidgetId
overlayWidgetId <- Getting (Maybe WidgetId) (MonomerCtx s e) (Maybe WidgetId)
-> m (Maybe WidgetId)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe WidgetId) (MonomerCtx s e) (Maybe WidgetId)
forall s a. HasOverlayWidgetId s a => Lens' s a
L.overlayWidgetId
  case Maybe WidgetId
overlayWidgetId of
    Just WidgetId
wid -> Path -> Maybe Path
forall a. a -> Maybe a
Just (Path -> Maybe Path) -> m Path -> m (Maybe Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
wid
    Maybe WidgetId
Nothing -> Maybe Path -> m (Maybe Path)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Path
forall a. Maybe a
Nothing

-- | Returns the current drag message and path, if any.
getDraggedMsgInfo :: (MonomerM s e m) => m (Maybe (Path, WidgetDragMsg))
getDraggedMsgInfo :: m (Maybe (Path, WidgetDragMsg))
getDraggedMsgInfo = do
  Maybe DragAction
dragAction <- Getting (Maybe DragAction) (MonomerCtx s e) (Maybe DragAction)
-> m (Maybe DragAction)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe DragAction) (MonomerCtx s e) (Maybe DragAction)
forall s a. HasDragAction s a => Lens' s a
L.dragAction
  case Maybe DragAction
dragAction of
    Just (DragAction WidgetId
wid WidgetDragMsg
msg) -> (Path, WidgetDragMsg) -> Maybe (Path, WidgetDragMsg)
forall a. a -> Maybe a
Just ((Path, WidgetDragMsg) -> Maybe (Path, WidgetDragMsg))
-> (Path -> (Path, WidgetDragMsg))
-> Path
-> Maybe (Path, WidgetDragMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, WidgetDragMsg
msg) (Path -> Maybe (Path, WidgetDragMsg))
-> m Path -> m (Maybe (Path, WidgetDragMsg))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
wid
    Maybe DragAction
Nothing -> Maybe (Path, WidgetDragMsg) -> m (Maybe (Path, WidgetDragMsg))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path, WidgetDragMsg)
forall a. Maybe a
Nothing

-- | Returns the current cursor and path that set it, if any.
getCurrentCursorIcon :: (MonomerM s e m) => m (Maybe (Path, CursorIcon))
getCurrentCursorIcon :: m (Maybe (Path, CursorIcon))
getCurrentCursorIcon = do
  Maybe (WidgetId, CursorIcon)
cursorHead <- ([(WidgetId, CursorIcon)] -> Maybe (WidgetId, CursorIcon))
-> m [(WidgetId, CursorIcon)] -> m (Maybe (WidgetId, CursorIcon))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(WidgetId, CursorIcon)] -> Maybe (WidgetId, CursorIcon)
forall a. [a] -> Maybe a
headMay (Getting
  [(WidgetId, CursorIcon)] (MonomerCtx s e) [(WidgetId, CursorIcon)]
-> m [(WidgetId, CursorIcon)]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  [(WidgetId, CursorIcon)] (MonomerCtx s e) [(WidgetId, CursorIcon)]
forall s a. HasCursorStack s a => Lens' s a
L.cursorStack)
  case Maybe (WidgetId, CursorIcon)
cursorHead of
    Just (WidgetId
wid, CursorIcon
icon) -> do
      Path
path <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
wid
      Maybe (Path, CursorIcon) -> m (Maybe (Path, CursorIcon))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Path, CursorIcon) -> m (Maybe (Path, CursorIcon)))
-> Maybe (Path, CursorIcon) -> m (Maybe (Path, CursorIcon))
forall a b. (a -> b) -> a -> b
$ (Path, CursorIcon) -> Maybe (Path, CursorIcon)
forall a. a -> Maybe a
Just (Path
path, CursorIcon
icon)
    Maybe (WidgetId, CursorIcon)
otherwhise -> Maybe (Path, CursorIcon) -> m (Maybe (Path, CursorIcon))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path, CursorIcon)
forall a. Maybe a
Nothing