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