{-|
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.Concurrent.STM.TChan
import Control.Lens ((^.), (.=), at, non, use)
import Data.Default

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.Types

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 :: forall s e.
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 {
  _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 :: forall s e (m :: * -> *). MonomerM s e m => 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
Lens' (MonomerCtx s e) (Map WidgetId Path)
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 (IxValue (Map WidgetId Path))
  -> Const Path (Maybe (IxValue (Map WidgetId Path))))
 -> Map WidgetId Path -> Const Path (Map WidgetId Path))
-> ((Path -> Const Path Path)
    -> Maybe (IxValue (Map WidgetId Path))
    -> Const Path (Maybe (IxValue (Map WidgetId Path))))
-> (Path -> Const Path Path)
-> Map WidgetId Path
-> Const Path (Map WidgetId Path)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IxValue (Map WidgetId Path)
-> Iso'
     (Maybe (IxValue (Map WidgetId Path))) (IxValue (Map WidgetId Path))
forall a. Eq a => a -> Iso' (Maybe a) a
non (WidgetId
widgetId WidgetId
-> Getting
     (IxValue (Map WidgetId Path))
     WidgetId
     (IxValue (Map WidgetId Path))
-> IxValue (Map WidgetId Path)
forall s a. s -> Getting a s a -> a
^. Getting
  (IxValue (Map WidgetId Path))
  WidgetId
  (IxValue (Map WidgetId Path))
forall s a. HasPath s a => Lens' s a
Lens' WidgetId (IxValue (Map WidgetId Path))
L.path)

-- | Updates the path associated to a "WidgetId".
setWidgetIdPath :: (MonomerM s e m) => WidgetId -> Path -> m ()
setWidgetIdPath :: forall s e (m :: * -> *).
MonomerM s e m =>
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
Lens' (MonomerCtx s e) (Map WidgetId Path)
L.widgetPaths ((Map WidgetId Path -> Identity (Map WidgetId Path))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe (IxValue (Map WidgetId Path)) -> Identity (Maybe Path))
    -> Map WidgetId Path -> Identity (Map WidgetId Path))
-> (Maybe (IxValue (Map WidgetId 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 (IxValue (Map WidgetId 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 :: forall s e (m :: * -> *). MonomerM s e m => 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
Lens' (MonomerCtx s e) (Map WidgetId Path)
L.widgetPaths ((Map WidgetId Path -> Identity (Map WidgetId Path))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe (IxValue (Map WidgetId Path))
     -> Identity (Maybe (IxValue (Map WidgetId Path))))
    -> Map WidgetId Path -> Identity (Map WidgetId Path))
-> (Maybe (IxValue (Map WidgetId Path))
    -> Identity (Maybe (IxValue (Map WidgetId 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 (IxValue (Map WidgetId Path))
  -> Identity (Maybe (IxValue (Map WidgetId Path))))
 -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe (IxValue (Map WidgetId Path)) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe (IxValue (Map WidgetId 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 :: forall s e (m :: * -> *). MonomerM s e m => 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
Lens' (MonomerCtx s e) (Maybe WidgetId)
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 a. a -> m a
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 :: forall s e (m :: * -> *). MonomerM s e m => 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
Lens' (MonomerCtx s e) WidgetId
L.focusedWidgetId

-- | Returns the path of the current overlay node, if any.
getOverlayPath :: (MonomerM s e m) => m (Maybe Path)
getOverlayPath :: forall s e (m :: * -> *). MonomerM s e m => 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
Lens' (MonomerCtx s e) (Maybe WidgetId)
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 a. a -> m a
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 :: forall s e (m :: * -> *).
MonomerM s e m =>
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
Lens' (MonomerCtx s e) (Maybe DragAction)
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 a. a -> m a
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 :: forall s e (m :: * -> *).
MonomerM s e m =>
m (Maybe (Path, CursorIcon))
getCurrentCursorIcon = do
  Maybe (WidgetId, CursorIcon)
cursorHead <- ([(WidgetId, CursorIcon)] -> Maybe (WidgetId, CursorIcon))
-> m [(WidgetId, CursorIcon)] -> m (Maybe (WidgetId, CursorIcon))
forall a b. (a -> b) -> m a -> m b
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
Lens' (MonomerCtx s e) [(WidgetId, CursorIcon)]
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 a. a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Path, CursorIcon)
forall a. Maybe a
Nothing