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