{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module Monomer.Main.Handlers (
HandlerStep,
handleSystemEvents,
handleResourcesInit,
handleWidgetInit,
handleWidgetDispose,
handleWidgetResult,
handleRequests,
handleResizeWidgets
) where
import Control.Concurrent.Async (async)
import Control.Lens
((&), (^.), (^?), (.~), (?~), (%~), (.=), (?=), (%=), (%%~), _Just, _1, _2, ix, at, use)
import Control.Monad.STM (atomically)
import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.IO.Class
import Data.Default
import Data.Foldable (fold, toList)
import Data.Maybe
import Data.Sequence (Seq(..), (|>))
import Data.Text (Text)
import Data.Typeable (Typeable, typeOf)
import Safe (headMay)
import SDL (($=))
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified SDL
import qualified SDL.Raw.Enum as SDLEnum
import qualified SDL.Raw.Event as SDLE
import qualified SDL.Raw.Types as SDLT
import Monomer.Core
import Monomer.Event
import Monomer.Helper (seqStartsWith)
import Monomer.Main.Types
import Monomer.Main.Util
import qualified Monomer.Lens as L
type HandlerStep s e = (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
handleSystemEvents
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> [SystemEvent]
-> m (HandlerStep s e)
handleSystemEvents :: WidgetEnv s e
-> WidgetNode s e -> [SystemEvent] -> m (HandlerStep s e)
handleSystemEvents WidgetEnv s e
wenv WidgetNode s e
widgetRoot [SystemEvent]
baseEvents = m (HandlerStep s e)
nextStep where
mainBtn :: Button
mainBtn = WidgetEnv s e
wenv WidgetEnv s e -> Getting Button (WidgetEnv s e) Button -> Button
forall s a. s -> Getting a s a -> a
^. Getting Button (WidgetEnv s e) Button
forall s a. HasMainButton s a => Lens' s a
L.mainButton
reduceEvt :: (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> SystemEvent
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
reduceEvt (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
curStep SystemEvent
evt = do
let (WidgetEnv s e
curWenv, WidgetNode s e
curRoot, Seq (WidgetRequest s e)
curReqs) = (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
curStep
[(SystemEvent, Maybe Path)]
systemEvents <- WidgetEnv s e
-> Button
-> WidgetNode s e
-> SystemEvent
-> m [(SystemEvent, Maybe Path)]
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> Button
-> WidgetNode s e
-> SystemEvent
-> m [(SystemEvent, Maybe Path)]
addRelatedEvents WidgetEnv s e
curWenv Button
mainBtn WidgetNode s e
curRoot SystemEvent
evt
((WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> (SystemEvent, Maybe Path)
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e)))
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> [(SystemEvent, Maybe Path)]
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> (SystemEvent, Maybe Path)
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall (m :: * -> *) s e.
(MonadIO m, MonadCatch m, Eq s, MonadState (MonomerCtx s e) m) =>
HandlerStep s e -> (SystemEvent, Maybe Path) -> m (HandlerStep s e)
reduceSysEvt (WidgetEnv s e
curWenv, WidgetNode s e
curRoot, Seq (WidgetRequest s e)
curReqs) [(SystemEvent, Maybe Path)]
systemEvents
reduceSysEvt :: HandlerStep s e -> (SystemEvent, Maybe Path) -> m (HandlerStep s e)
reduceSysEvt HandlerStep s e
curStep (SystemEvent
evt, Maybe Path
evtTarget) = do
Path
focused <- m Path
forall s e (m :: * -> *). MonomerM s e m => m Path
getFocusedPath
let (WidgetEnv s e
curWenv, WidgetNode s e
curRoot, Seq (WidgetRequest s e)
curReqs) = HandlerStep s e
curStep
let target :: Path
target = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
focused Maybe Path
evtTarget
let curWidget :: Widget s e
curWidget = WidgetNode s e
curRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let targetWni :: Maybe WidgetNodeInfo
targetWni = Maybe Path
evtTarget Maybe Path
-> (Path -> Maybe WidgetNodeInfo) -> Maybe WidgetNodeInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
forall s e.
WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
findWidgetByPath WidgetEnv s e
curWenv WidgetNode s e
curRoot
let targetWid :: Maybe WidgetId
targetWid = (WidgetNodeInfo
-> Getting WidgetId WidgetNodeInfo WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. Getting WidgetId WidgetNodeInfo WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId) (WidgetNodeInfo -> WidgetId)
-> Maybe WidgetNodeInfo -> Maybe WidgetId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe WidgetNodeInfo
targetWni
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SystemEvent -> Bool
isOnEnter SystemEvent
evt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
(Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasHoveredWidgetId s a => Lens' s a
L.hoveredWidgetId ((Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe WidgetId
targetWid
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SystemEvent -> Bool
isOnMove SystemEvent
evt)
m ()
forall s e (m :: * -> *). MonomerM s e m => m ()
restoreCursorOnWindowEnter
Maybe (Path, CursorIcon)
cursorIcon <- m (Maybe (Path, CursorIcon))
forall s e (m :: * -> *).
MonomerM s e m =>
m (Maybe (Path, CursorIcon))
getCurrentCursorIcon
Maybe Path
hoveredPath <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getHoveredPath
Maybe (Path, Point)
mainBtnPress <- Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
-> m (Maybe (Path, Point))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
InputStatus
inputStatus <- Getting InputStatus (MonomerCtx s e) InputStatus -> m InputStatus
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting InputStatus (MonomerCtx s e) InputStatus
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus
let tmpWenv :: WidgetEnv s e
tmpWenv = WidgetEnv s e
curWenv
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Maybe (Path, CursorIcon) -> Identity (Maybe (Path, CursorIcon)))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasCursor s a => Lens' s a
L.cursor ((Maybe (Path, CursorIcon) -> Identity (Maybe (Path, CursorIcon)))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Maybe (Path, CursorIcon) -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Path, CursorIcon)
cursorIcon
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Maybe Path -> Identity (Maybe Path))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasHoveredPath s a => Lens' s a
L.hoveredPath ((Maybe Path -> Identity (Maybe Path))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Maybe Path -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Path
hoveredPath
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress ((Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Maybe (Path, Point) -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Path, Point)
mainBtnPress
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (InputStatus -> Identity InputStatus)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> InputStatus -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InputStatus
inputStatus
let findByPath :: Path -> Maybe WidgetNodeInfo
findByPath Path
path = WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
forall s e.
WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
findWidgetByPath WidgetEnv s e
tmpWenv WidgetNode s e
curRoot Path
path
let newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
tmpWenv
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& ((Path -> Maybe WidgetNodeInfo)
-> Identity (Path -> Maybe WidgetNodeInfo))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFindByPath s a => Lens' s a
L.findByPath (((Path -> Maybe WidgetNodeInfo)
-> Identity (Path -> Maybe WidgetNodeInfo))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Path -> Maybe WidgetNodeInfo) -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path -> Maybe WidgetNodeInfo
findByPath
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
newWenv WidgetNode s e
curRoot SystemEvent
evt Path
target
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SystemEvent -> Bool
isOnLeave SystemEvent
evt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
SystemEvent -> HandlerStep s e -> m ()
forall s e (m :: * -> *).
MonomerM s e m =>
SystemEvent -> HandlerStep s e -> m ()
resetCursorOnNodeLeave SystemEvent
evt HandlerStep s e
curStep
(Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasHoveredWidgetId s a => Lens' s a
L.hoveredWidgetId ((Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe WidgetId
forall a. Maybe a
Nothing
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
curReqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
newEvents :: [SystemEvent]
newEvents = [SystemEvent] -> [SystemEvent]
preProcessEvents [SystemEvent]
baseEvents
nextStep :: m (HandlerStep s e)
nextStep = (HandlerStep s e -> SystemEvent -> m (HandlerStep s e))
-> HandlerStep s e -> [SystemEvent] -> m (HandlerStep s e)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HandlerStep s e -> SystemEvent -> m (HandlerStep s e)
forall (m :: * -> *) s e.
(Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m) =>
(WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> SystemEvent
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
reduceEvt (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty) [SystemEvent]
newEvents
handleSystemEvent
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> SystemEvent
-> Path
-> m (HandlerStep s e)
handleSystemEvent :: WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
wenv WidgetNode s e
widgetRoot SystemEvent
event Path
currentTarget = do
Maybe (Path, Point)
mainStart <- Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
-> m (Maybe (Path, Point))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
Maybe Path
overlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
Bool
leaveEnterPair <- Getting Bool (MonomerCtx s e) Bool -> m Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool (MonomerCtx s e) Bool
forall s a. HasLeaveEnterPair s a => Lens' s a
L.leaveEnterPair
let pressed :: Maybe Path
pressed = ((Path, Point) -> Path) -> Maybe (Path, Point) -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path, Point) -> Path
forall a b. (a, b) -> a
fst Maybe (Path, Point)
mainStart
case WidgetEnv s e
-> WidgetNode s e
-> Maybe Path
-> Maybe Path
-> Path
-> SystemEvent
-> Maybe Path
forall s e.
WidgetEnv s e
-> WidgetNode s e
-> Maybe Path
-> Maybe Path
-> Path
-> SystemEvent
-> Maybe Path
getTargetPath WidgetEnv s e
wenv WidgetNode s e
widgetRoot Maybe Path
pressed Maybe Path
overlay Path
currentTarget SystemEvent
event of
Maybe Path
Nothing -> HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
widgetRoot, Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty)
Just Path
target -> do
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let emptyResult :: WidgetResult s e
emptyResult = WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
forall s e.
WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
WidgetResult WidgetNode s e
widgetRoot Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty
let evtResult :: Maybe (WidgetResult s e)
evtResult = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> SystemEvent
-> Maybe (WidgetResult s e)
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> SystemEvent
-> Maybe (WidgetResult s e)
widgetHandleEvent Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot Path
target SystemEvent
event
let resizeWidgets :: Bool
resizeWidgets = Bool -> Bool
not (Bool
leaveEnterPair Bool -> Bool -> Bool
&& SystemEvent -> Bool
isOnLeave SystemEvent
event)
let widgetResult :: WidgetResult s e
widgetResult = WidgetResult s e -> Maybe (WidgetResult s e) -> WidgetResult s e
forall a. a -> Maybe a -> a
fromMaybe WidgetResult s e
emptyResult Maybe (WidgetResult s e)
evtResult
WidgetResult s e
-> (WidgetResult s e -> WidgetResult s e) -> WidgetResult s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> WidgetResult s e -> Identity (WidgetResult s e)
forall s a. HasRequests s a => Lens' s a
L.requests ((Seq (WidgetRequest s e) -> Identity (Seq (WidgetRequest s e)))
-> WidgetResult s e -> Identity (WidgetResult s e))
-> (Seq (WidgetRequest s e) -> Seq (WidgetRequest s e))
-> WidgetResult s e
-> WidgetResult s e
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ SystemEvent -> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall s e.
SystemEvent -> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
addFocusReq SystemEvent
event
HandlerStep s e
step <- WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
wenv Bool
resizeWidgets WidgetResult s e
widgetResult
if SystemEvent -> Bool
isOnDrop SystemEvent
event
then HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleFinalizeDrop HandlerStep s e
step
else HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
handleResourcesInit :: MonomerM s e m => m ()
handleResourcesInit :: m ()
handleResourcesInit = do
Map CursorIcon Cursor
cursors <- (Map CursorIcon Cursor -> CursorIcon -> m (Map CursorIcon Cursor))
-> Map CursorIcon Cursor
-> [CursorIcon]
-> m (Map CursorIcon Cursor)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map CursorIcon Cursor -> CursorIcon -> m (Map CursorIcon Cursor)
forall (m :: * -> *).
MonadIO m =>
Map CursorIcon Cursor -> CursorIcon -> m (Map CursorIcon Cursor)
insert Map CursorIcon Cursor
forall k a. Map k a
Map.empty [Int -> CursorIcon
forall a. Enum a => Int -> a
toEnum Int
0 ..]
(Map CursorIcon Cursor -> Identity (Map CursorIcon Cursor))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasCursorIcons s a => Lens' s a
L.cursorIcons ((Map CursorIcon Cursor -> Identity (Map CursorIcon Cursor))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Map CursorIcon Cursor -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Map CursorIcon Cursor
cursors
where
insert :: Map CursorIcon Cursor -> CursorIcon -> m (Map CursorIcon Cursor)
insert Map CursorIcon Cursor
map CursorIcon
icon = do
Cursor
cursor <- SystemCursor -> m Cursor
forall (m :: * -> *). MonadIO m => SystemCursor -> m Cursor
SDLE.createSystemCursor (CursorIcon -> SystemCursor
cursorToSDL CursorIcon
icon)
Map CursorIcon Cursor -> m (Map CursorIcon Cursor)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map CursorIcon Cursor -> m (Map CursorIcon Cursor))
-> Map CursorIcon Cursor -> m (Map CursorIcon Cursor)
forall a b. (a -> b) -> a -> b
$ CursorIcon
-> Cursor -> Map CursorIcon Cursor -> Map CursorIcon Cursor
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CursorIcon
icon Cursor
cursor Map CursorIcon Cursor
map
handleWidgetInit
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> m (HandlerStep s e)
handleWidgetInit :: WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetInit WidgetEnv s e
wenv WidgetNode s e
widgetRoot = do
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let widgetResult :: WidgetResult s e
widgetResult = Widget s e -> WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
widgetInit Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot
let reqs :: Seq (WidgetRequest s e)
reqs = WidgetResult s e
widgetResult WidgetResult s e
-> Getting
(Seq (WidgetRequest s e))
(WidgetResult s e)
(Seq (WidgetRequest s e))
-> Seq (WidgetRequest s e)
forall s a. s -> Getting a s a -> a
^. Getting
(Seq (WidgetRequest s e))
(WidgetResult s e)
(Seq (WidgetRequest s e))
forall s a. HasRequests s a => Lens' s a
L.requests
let focusReqExists :: Bool
focusReqExists = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ (WidgetRequest s e -> Bool) -> Seq (WidgetRequest s e) -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
Seq.findIndexL WidgetRequest s e -> Bool
forall s e. WidgetRequest s e -> Bool
isFocusRequest Seq (WidgetRequest s e)
reqs
(Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasResizeRequests s a => Lens' s a
L.resizeRequests ((Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Seq WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetId -> Seq WidgetId
forall a. a -> Seq a
Seq.singleton WidgetId
forall a. Default a => a
def
HandlerStep s e
step <- WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
wenv Bool
True WidgetResult s e
widgetResult
Path
currFocus <- m Path
forall s e (m :: * -> *). MonomerM s e m => m Path
getFocusedPath
if Bool -> Bool
not Bool
focusReqExists Bool -> Bool -> Bool
&& Path
currFocus Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
emptyPath
then Maybe WidgetId
-> FocusDirection -> HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
Maybe WidgetId
-> FocusDirection -> HandlerStep s e -> m (HandlerStep s e)
handleMoveFocus Maybe WidgetId
forall a. Maybe a
Nothing FocusDirection
FocusFwd HandlerStep s e
step
else HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
handleWidgetDispose
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> m (HandlerStep s e)
handleWidgetDispose :: WidgetEnv s e -> WidgetNode s e -> m (HandlerStep s e)
handleWidgetDispose WidgetEnv s e
wenv WidgetNode s e
widgetRoot = do
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let widgetResult :: WidgetResult s e
widgetResult = Widget s e -> WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> WidgetResult s e
widgetDispose Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
wenv Bool
False WidgetResult s e
widgetResult
handleWidgetResult
:: MonomerM s e m
=> WidgetEnv s e
-> Bool
-> WidgetResult s e
-> m (HandlerStep s e)
handleWidgetResult :: WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
wenv Bool
resizeWidgets WidgetResult s e
result = do
let WidgetResult WidgetNode s e
evtRoot Seq (WidgetRequest s e)
reqs = WidgetResult s e
result
HandlerStep s e
step <- Seq (WidgetRequest s e) -> HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
Seq (WidgetRequest s e) -> HandlerStep s e -> m (HandlerStep s e)
handleRequests Seq (WidgetRequest s e)
reqs (WidgetEnv s e
wenv, WidgetNode s e
evtRoot, Seq (WidgetRequest s e)
reqs)
Seq WidgetId
resizeRequests <- Getting (Seq WidgetId) (MonomerCtx s e) (Seq WidgetId)
-> m (Seq WidgetId)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Seq WidgetId) (MonomerCtx s e) (Seq WidgetId)
forall s a. HasResizeRequests s a => Lens' s a
L.resizeRequests
if Bool
resizeWidgets Bool -> Bool -> Bool
&& Bool -> Bool
not (Seq WidgetId -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq WidgetId
resizeRequests)
then HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleResizeWidgets HandlerStep s e
step
else HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
handleRequests
:: MonomerM s e m
=> Seq (WidgetRequest s e)
-> HandlerStep s e
-> m (HandlerStep s e)
handleRequests :: Seq (WidgetRequest s e) -> HandlerStep s e -> m (HandlerStep s e)
handleRequests Seq (WidgetRequest s e)
reqs HandlerStep s e
step = (HandlerStep s e -> WidgetRequest s e -> m (HandlerStep s e))
-> HandlerStep s e
-> Seq (WidgetRequest s e)
-> m (HandlerStep s e)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HandlerStep s e -> WidgetRequest s e -> m (HandlerStep s e)
forall (m :: * -> *) s e e.
(Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m) =>
(WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> WidgetRequest s e
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
handleRequest HandlerStep s e
step Seq (WidgetRequest s e)
reqs where
handleRequest :: (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> WidgetRequest s e
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
handleRequest (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step WidgetRequest s e
req = case WidgetRequest s e
req of
WidgetRequest s e
IgnoreParentEvents -> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
WidgetRequest s e
IgnoreChildrenEvents -> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
ResizeWidgets WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleAddPendingResize WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
ResizeWidgetsImmediate WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResizeImmediate WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
MoveFocus Maybe WidgetId
start FocusDirection
dir -> Maybe WidgetId
-> FocusDirection
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
Maybe WidgetId
-> FocusDirection -> HandlerStep s e -> m (HandlerStep s e)
handleMoveFocus Maybe WidgetId
start FocusDirection
dir (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
SetFocus WidgetId
path -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleSetFocus WidgetId
path (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
GetClipboard WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleGetClipboard WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
SetClipboard ClipboardData
cdata -> ClipboardData
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
ClipboardData -> HandlerStep s e -> m (HandlerStep s e)
handleSetClipboard ClipboardData
cdata (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
StartTextInput Rect
rect -> Rect
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
Rect -> HandlerStep s e -> m (HandlerStep s e)
handleStartTextInput Rect
rect (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
WidgetRequest s e
StopTextInput -> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleStopTextInput (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
SetOverlay WidgetId
wid Path
path -> WidgetId
-> Path
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e)
handleSetOverlay WidgetId
wid Path
path (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
ResetOverlay WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetOverlay WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
SetCursorIcon WidgetId
wid CursorIcon
icon -> WidgetId
-> CursorIcon
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> CursorIcon -> HandlerStep s e -> m (HandlerStep s e)
handleSetCursorIcon WidgetId
wid CursorIcon
icon (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
ResetCursorIcon WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetCursorIcon WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
StartDrag WidgetId
wid Path
path WidgetDragMsg
info -> WidgetId
-> Path
-> WidgetDragMsg
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId
-> Path -> WidgetDragMsg -> HandlerStep s e -> m (HandlerStep s e)
handleStartDrag WidgetId
wid Path
path WidgetDragMsg
info (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
StopDrag WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleStopDrag WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
WidgetRequest s e
RenderOnce -> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleRenderOnce (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
RenderEvery WidgetId
wid Int
ms Maybe Int
repeat -> WidgetId
-> Int
-> Maybe Int
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId
-> Int -> Maybe Int -> HandlerStep s e -> m (HandlerStep s e)
handleRenderEvery WidgetId
wid Int
ms Maybe Int
repeat (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
RenderStop WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleRenderStop WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
RemoveRendererImage Text
path -> Text
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
Text -> HandlerStep s e -> m (HandlerStep s e)
handleRemoveRendererImage Text
path (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
ExitApplication Bool
exit -> Bool
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
Bool -> HandlerStep s e -> m (HandlerStep s e)
handleExitApplication Bool
exit (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
UpdateWindow WindowRequest
req -> WindowRequest
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WindowRequest -> HandlerStep s e -> m (HandlerStep s e)
handleUpdateWindow WindowRequest
req (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
UpdateModel s -> s
fn -> (s -> s)
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
(s -> s) -> HandlerStep s e -> m (HandlerStep s e)
handleUpdateModel s -> s
fn (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
SetWidgetPath WidgetId
wid Path
path -> WidgetId
-> Path
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e)
handleSetWidgetPath WidgetId
wid Path
path (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
ResetWidgetPath WidgetId
wid -> WidgetId
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetWidgetPath WidgetId
wid (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
RaiseEvent e
msg -> e
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *) msg.
(MonomerM s e m, Typeable msg) =>
msg -> HandlerStep s e -> m (HandlerStep s e)
handleRaiseEvent e
msg (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
SendMessage WidgetId
wid i
msg -> WidgetId
-> i
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *) msg.
(MonomerM s e m, Typeable msg) =>
WidgetId -> msg -> HandlerStep s e -> m (HandlerStep s e)
handleSendMessage WidgetId
wid i
msg (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
RunTask WidgetId
wid Path
path IO i
handler -> WidgetId
-> Path
-> IO i
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *) i.
(MonomerM s e m, Typeable i) =>
WidgetId -> Path -> IO i -> HandlerStep s e -> m (HandlerStep s e)
handleRunTask WidgetId
wid Path
path IO i
handler (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
RunProducer WidgetId
wid Path
path (i -> IO ()) -> IO ()
handler -> WidgetId
-> Path
-> ((i -> IO ()) -> IO ())
-> (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
-> m (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
forall s e (m :: * -> *) i.
(MonomerM s e m, Typeable i) =>
WidgetId
-> Path
-> ((i -> IO ()) -> IO ())
-> HandlerStep s e
-> m (HandlerStep s e)
handleRunProducer WidgetId
wid Path
path (i -> IO ()) -> IO ()
handler (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step
handleResizeWidgets
:: MonomerM s e m
=> HandlerStep s e
-> m (HandlerStep s e)
handleResizeWidgets :: HandlerStep s e -> m (HandlerStep s e)
handleResizeWidgets HandlerStep s e
previousStep = do
Size
windowSize <- Getting Size (MonomerCtx s e) Size -> m Size
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Size (MonomerCtx s e) Size
forall s a. HasWindowSize s a => Lens' s a
L.windowSize
Path -> Bool
resizeCheckFn <- m (Path -> Bool)
makeResizeChechFn
let viewport :: Rect
viewport = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 (Size
windowSize Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasW s a => Lens' s a
L.w) (Size
windowSize Size -> Getting Double Size Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double Size Double
forall s a. HasH s a => Lens' s a
L.h)
let (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = HandlerStep s e
previousStep
let newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
wenv
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Size -> Identity Size)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasWindowSize s a => Lens' s a
L.windowSize ((Size -> Identity Size)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Size -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Size
windowSize
WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Rect -> Identity Rect)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasViewport s a => Lens' s a
L.viewport ((Rect -> Identity Rect)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Rect -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Rect
viewport
let rootWidget :: Widget s e
rootWidget = WidgetNode s e
root WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let newResult :: WidgetResult s e
newResult = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Rect
-> (Path -> Bool)
-> WidgetResult s e
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Rect
-> (Path -> Bool)
-> WidgetResult s e
widgetResize Widget s e
rootWidget WidgetEnv s e
newWenv WidgetNode s e
root Rect
viewport Path -> Bool
resizeCheckFn
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
(Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasResizeRequests s a => Lens' s a
L.resizeRequests ((Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Seq WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Seq WidgetId
forall a. Seq a
Seq.empty
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
newWenv Bool
True WidgetResult s e
newResult
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
where
makeResizeChechFn :: m (Path -> Bool)
makeResizeChechFn = do
Seq WidgetId
resizeRequests <- Getting (Seq WidgetId) (MonomerCtx s e) (Seq WidgetId)
-> m (Seq WidgetId)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Seq WidgetId) (MonomerCtx s e) (Seq WidgetId)
forall s a. HasResizeRequests s a => Lens' s a
L.resizeRequests
Seq Path
paths <- (WidgetId -> m Path) -> Seq WidgetId -> m (Seq Path)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath Seq WidgetId
resizeRequests
let parts :: Seq a -> Set (Seq a)
parts = [Seq a] -> Set (Seq a)
forall a. [a] -> Set a
Set.fromDistinctAscList ([Seq a] -> Set (Seq a))
-> (Seq a -> [Seq a]) -> Seq a -> Set (Seq a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Seq a] -> [Seq a]
forall a. Int -> [a] -> [a]
drop Int
1 ([Seq a] -> [Seq a]) -> (Seq a -> [Seq a]) -> Seq a -> [Seq a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Seq a) -> [Seq a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Seq a) -> [Seq a])
-> (Seq a -> Seq (Seq a)) -> Seq a -> [Seq a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> Seq (Seq a)
forall a. Seq a -> Seq (Seq a)
Seq.inits
let sets :: Set Path
sets = Seq (Set Path) -> Set Path
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Path -> Set Path
forall a. Seq a -> Set (Seq a)
parts (Path -> Set Path) -> Seq Path -> Seq (Set Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Path
paths)
(Path -> Bool) -> m (Path -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> Set Path -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Path
sets)
handleAddPendingResize
:: MonomerM s e m
=> WidgetId
-> HandlerStep s e
-> m (HandlerStep s e)
handleAddPendingResize :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleAddPendingResize WidgetId
wid HandlerStep s e
step = do
(Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasResizeRequests s a => Lens' s a
L.resizeRequests ((Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> (Seq WidgetId -> Seq WidgetId) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Seq WidgetId -> WidgetId -> Seq WidgetId
forall a. Seq a -> a -> Seq a
|> WidgetId
wid)
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
handleResizeImmediate
:: MonomerM s e m
=> WidgetId
-> HandlerStep s e
-> m (HandlerStep s e)
handleResizeImmediate :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResizeImmediate WidgetId
wid HandlerStep s e
step = do
(Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasResizeRequests s a => Lens' s a
L.resizeRequests ((Seq WidgetId -> Identity (Seq WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> (Seq WidgetId -> Seq WidgetId) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Seq WidgetId -> WidgetId -> Seq WidgetId
forall a. Seq a -> a -> Seq a
|> WidgetId
wid)
HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
HandlerStep s e -> m (HandlerStep s e)
handleResizeWidgets HandlerStep s e
step
handleMoveFocus
:: MonomerM s e m
=> Maybe WidgetId
-> FocusDirection
-> HandlerStep s e
-> m (HandlerStep s e)
handleMoveFocus :: Maybe WidgetId
-> FocusDirection -> HandlerStep s e -> m (HandlerStep s e)
handleMoveFocus Maybe WidgetId
startFromWid FocusDirection
dir (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = do
Path
oldFocus <- m Path
forall s e (m :: * -> *). MonomerM s e m => m Path
getFocusedPath
Maybe Path
tmpOverlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
let tmpFocusWni :: WidgetNodeInfo
tmpFocusWni = WidgetEnv s e
-> FocusDirection
-> Path
-> Maybe Path
-> WidgetNode s e
-> WidgetNodeInfo
forall s e.
WidgetEnv s e
-> FocusDirection
-> Path
-> Maybe Path
-> WidgetNode s e
-> WidgetNodeInfo
findNextFocus WidgetEnv s e
wenv FocusDirection
dir Path
oldFocus Maybe Path
tmpOverlay WidgetNode s e
root
let tmpFocus :: Path
tmpFocus = WidgetNodeInfo
tmpFocusWni WidgetNodeInfo -> Getting Path WidgetNodeInfo Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetNodeInfo Path
forall s a. HasPath s a => Lens' s a
L.path
let blurEvt :: SystemEvent
blurEvt = Path -> SystemEvent
Blur Path
tmpFocus
let wenv0 :: WidgetEnv s e
wenv0 = WidgetEnv s e
wenv WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFocusedPath s a => Lens' s a
L.focusedPath ((Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Path -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path
tmpFocus
(WidgetEnv s e
wenv1, WidgetNode s e
root1, Seq (WidgetRequest s e)
reqs1) <- WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
wenv0 WidgetNode s e
root SystemEvent
blurEvt Path
oldFocus
Path
currFocus <- m Path
forall s e (m :: * -> *). MonomerM s e m => m Path
getFocusedPath
Maybe Path
currOverlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
if Path
oldFocus Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
currFocus
then do
Maybe Path
startFrom <- (WidgetId -> m Path) -> Maybe WidgetId -> m (Maybe Path)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath Maybe WidgetId
startFromWid
let searchFrom :: Path
searchFrom = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
currFocus Maybe Path
startFrom
let newFocusWni :: WidgetNodeInfo
newFocusWni = WidgetEnv s e
-> FocusDirection
-> Path
-> Maybe Path
-> WidgetNode s e
-> WidgetNodeInfo
forall s e.
WidgetEnv s e
-> FocusDirection
-> Path
-> Maybe Path
-> WidgetNode s e
-> WidgetNodeInfo
findNextFocus WidgetEnv s e
wenv1 FocusDirection
dir Path
searchFrom Maybe Path
currOverlay WidgetNode s e
root1
let newFocus :: Path
newFocus = WidgetNodeInfo
newFocusWni WidgetNodeInfo -> Getting Path WidgetNodeInfo Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetNodeInfo Path
forall s a. HasPath s a => Lens' s a
L.path
let wenvF :: WidgetEnv s e
wenvF = WidgetEnv s e
wenv1 WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFocusedPath s a => Lens' s a
L.focusedPath ((Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Path -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path
newFocus
let focusEvt :: SystemEvent
focusEvt = Path -> SystemEvent
Focus Path
oldFocus
(WidgetId -> Identity WidgetId)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasFocusedWidgetId s a => Lens' s a
L.focusedWidgetId ((WidgetId -> Identity WidgetId)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetNodeInfo
newFocusWni WidgetNodeInfo
-> Getting WidgetId WidgetNodeInfo WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. Getting WidgetId WidgetNodeInfo WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
wenvF WidgetNode s e
root1 SystemEvent
focusEvt Path
newFocus
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs1 Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
else
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv1, WidgetNode s e
root1, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs1)
handleSetFocus
:: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleSetFocus :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleSetFocus WidgetId
newFocusWid (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = do
Path
newFocus <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
newFocusWid
Path
oldFocus <- m Path
forall s e (m :: * -> *). MonomerM s e m => m Path
getFocusedPath
if Path
oldFocus Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Path
newFocus Bool -> Bool -> Bool
&& Path
newFocus Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Path
emptyPath
then do
let wenv0 :: WidgetEnv s e
wenv0 = WidgetEnv s e
wenv WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFocusedPath s a => Lens' s a
L.focusedPath ((Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Path -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path
newFocus
let blurEvt :: SystemEvent
blurEvt = Path -> SystemEvent
Blur Path
newFocus
(WidgetEnv s e
wenv1, WidgetNode s e
root1, Seq (WidgetRequest s e)
reqs1) <- WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
wenv0 WidgetNode s e
root SystemEvent
blurEvt Path
oldFocus
let wenvF :: WidgetEnv s e
wenvF = WidgetEnv s e
wenv1 WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFocusedPath s a => Lens' s a
L.focusedPath ((Path -> Identity Path)
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Path -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Path
newFocus
let focusEvt :: SystemEvent
focusEvt = Path -> SystemEvent
Focus Path
oldFocus
(WidgetId -> Identity WidgetId)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasFocusedWidgetId s a => Lens' s a
L.focusedWidgetId ((WidgetId -> Identity WidgetId)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetId
newFocusWid
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
wenvF WidgetNode s e
root1 SystemEvent
focusEvt Path
newFocus
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs1 Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
else
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs)
handleGetClipboard
:: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleGetClipboard :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleGetClipboard WidgetId
widgetId (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = do
Path
path <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
widgetId
Bool
hasText <- m Bool
forall (m :: * -> *). MonadIO m => m Bool
SDL.hasClipboardText
SystemEvent
contents <- (ClipboardData -> SystemEvent) -> m ClipboardData -> m SystemEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClipboardData -> SystemEvent
Clipboard (m ClipboardData -> m SystemEvent)
-> m ClipboardData -> m SystemEvent
forall a b. (a -> b) -> a -> b
$ if Bool
hasText
then (Text -> ClipboardData) -> m Text -> m ClipboardData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ClipboardData
ClipboardText m Text
forall (m :: * -> *). MonadIO m => m Text
SDL.getClipboardText
else ClipboardData -> m ClipboardData
forall (m :: * -> *) a. Monad m => a -> m a
return ClipboardData
ClipboardEmpty
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> SystemEvent -> Path -> m (HandlerStep s e)
handleSystemEvent WidgetEnv s e
wenv WidgetNode s e
root SystemEvent
contents Path
path
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
handleSetClipboard
:: MonomerM s e m => ClipboardData -> HandlerStep s e -> m (HandlerStep s e)
handleSetClipboard :: ClipboardData -> HandlerStep s e -> m (HandlerStep s e)
handleSetClipboard (ClipboardText Text
text) HandlerStep s e
previousStep = do
Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
SDL.setClipboardText Text
text
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleSetClipboard ClipboardData
_ HandlerStep s e
previousStep = HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleStartTextInput
:: MonomerM s e m => Rect -> HandlerStep s e -> m (HandlerStep s e)
handleStartTextInput :: Rect -> HandlerStep s e -> m (HandlerStep s e)
handleStartTextInput (Rect Double
x Double
y Double
w Double
h) HandlerStep s e
previousStep = do
Rect -> m ()
forall (m :: * -> *). MonadIO m => Rect -> m ()
SDL.startTextInput (CInt -> CInt -> CInt -> CInt -> Rect
SDLT.Rect (Double -> CInt
forall a b. (RealFrac a, Num b) => a -> b
c Double
x) (Double -> CInt
forall a b. (RealFrac a, Num b) => a -> b
c Double
y) (Double -> CInt
forall a b. (RealFrac a, Num b) => a -> b
c Double
w) (Double -> CInt
forall a b. (RealFrac a, Num b) => a -> b
c Double
h))
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
where
c :: a -> b
c a
x = Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> b) -> Integer -> b
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round a
x
handleStopTextInput :: MonomerM s e m => HandlerStep s e -> m (HandlerStep s e)
handleStopTextInput :: HandlerStep s e -> m (HandlerStep s e)
handleStopTextInput HandlerStep s e
previousStep = do
m ()
forall (m :: * -> *). MonadIO m => m ()
SDL.stopTextInput
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleSetOverlay
:: MonomerM s e m
=> WidgetId
-> Path
-> HandlerStep s e
-> m (HandlerStep s e)
handleSetOverlay :: WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e)
handleSetOverlay WidgetId
widgetId Path
path HandlerStep s e
previousStep = do
Maybe WidgetId
overlay <- 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
(Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasOverlayWidgetId s a => Lens' s a
L.overlayWidgetId ((Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetId -> Maybe WidgetId
forall a. a -> Maybe a
Just WidgetId
widgetId
WidgetId -> Path -> m ()
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> m ()
setWidgetIdPath WidgetId
widgetId Path
path
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlerStep s e -> m (HandlerStep s e))
-> HandlerStep s e -> m (HandlerStep s e)
forall a b. (a -> b) -> a -> b
$ HandlerStep s e
previousStep
HandlerStep s e
-> (HandlerStep s e -> HandlerStep s e) -> HandlerStep s e
forall a b. a -> (a -> b) -> b
& (WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> ((Maybe Path -> Identity (Maybe Path))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Maybe Path -> Identity (Maybe Path))
-> HandlerStep s e
-> Identity (HandlerStep s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Path -> Identity (Maybe Path))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasOverlayPath s a => Lens' s a
L.overlayPath ((Maybe Path -> Identity (Maybe Path))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> Path -> HandlerStep s e -> HandlerStep s e
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Path
path
handleResetOverlay
:: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetOverlay :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetOverlay WidgetId
widgetId HandlerStep s e
step = do
let (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = HandlerStep s e
step
let mousePos :: Point
mousePos = WidgetEnv s e
wenv WidgetEnv s e -> Getting Point (WidgetEnv s e) Point -> Point
forall s a. s -> Getting a s a -> a
^. (InputStatus -> Const Point InputStatus)
-> WidgetEnv s e -> Const Point (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Const Point InputStatus)
-> WidgetEnv s e -> Const Point (WidgetEnv s e))
-> ((Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus)
-> Getting Point (WidgetEnv s e) Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus
forall s a. HasMousePos s a => Lens' s a
L.mousePos
Maybe WidgetId
overlay <- 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
(WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs2) <- if Maybe WidgetId
overlay Maybe WidgetId -> Maybe WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId -> Maybe WidgetId
forall a. a -> Maybe a
Just WidgetId
widgetId
then do
let newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
wenv WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (Maybe Path -> Identity (Maybe Path))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasOverlayPath s a => Lens' s a
L.overlayPath ((Maybe Path -> Identity (Maybe Path))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> Maybe Path -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Path
forall a. Maybe a
Nothing
(Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasOverlayWidgetId s a => Lens' s a
L.overlayWidgetId ((Maybe WidgetId -> Identity (Maybe WidgetId))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe WidgetId -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe WidgetId
forall a. Maybe a
Nothing
m (HandlerStep s e) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (HandlerStep s e) -> m ()) -> m (HandlerStep s e) -> m ()
forall a b. (a -> b) -> a -> b
$ WidgetId -> HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetCursorIcon WidgetId
widgetId HandlerStep s e
step
WidgetEnv s e
-> WidgetNode s e -> [SystemEvent] -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e -> [SystemEvent] -> m (HandlerStep s e)
handleSystemEvents WidgetEnv s e
newWenv WidgetNode s e
root [Point -> SystemEvent
Move Point
mousePos]
else
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
forall a. Seq a
Empty)
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root2, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
reqs2)
handleSetCursorIcon
:: MonomerM s e m
=> WidgetId
-> CursorIcon
-> HandlerStep s e
-> m (HandlerStep s e)
handleSetCursorIcon :: WidgetId -> CursorIcon -> HandlerStep s e -> m (HandlerStep s e)
handleSetCursorIcon WidgetId
wid CursorIcon
icon HandlerStep s e
previousStep = do
[(WidgetId, CursorIcon)]
cursors <- 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 m [(WidgetId, CursorIcon)]
-> ([(WidgetId, CursorIcon)] -> m [(WidgetId, CursorIcon)])
-> m [(WidgetId, CursorIcon)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetId -> [(WidgetId, CursorIcon)] -> m [(WidgetId, CursorIcon)]
forall s e (m :: * -> *) a.
MonomerM s e m =>
WidgetId -> [(WidgetId, a)] -> m [(WidgetId, a)]
dropNonParentWidgetId WidgetId
wid
([(WidgetId, CursorIcon)] -> Identity [(WidgetId, CursorIcon)])
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasCursorStack s a => Lens' s a
L.cursorStack (([(WidgetId, CursorIcon)] -> Identity [(WidgetId, CursorIcon)])
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> [(WidgetId, CursorIcon)] -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (WidgetId
wid, CursorIcon
icon) (WidgetId, CursorIcon)
-> [(WidgetId, CursorIcon)] -> [(WidgetId, CursorIcon)]
forall a. a -> [a] -> [a]
: [(WidgetId, CursorIcon)]
cursors
Maybe Cursor
cursor <- CursorIcon -> Map CursorIcon Cursor -> Maybe Cursor
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CursorIcon
icon (Map CursorIcon Cursor -> Maybe Cursor)
-> m (Map CursorIcon Cursor) -> m (Maybe Cursor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
(Map CursorIcon Cursor) (MonomerCtx s e) (Map CursorIcon Cursor)
-> m (Map CursorIcon Cursor)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Map CursorIcon Cursor) (MonomerCtx s e) (Map CursorIcon Cursor)
forall s a. HasCursorIcons s a => Lens' s a
L.cursorIcons
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Cursor -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Cursor
cursor) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid handleSetCursorIcon: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CursorIcon -> String
forall a. Show a => a -> String
show CursorIcon
icon
Maybe Cursor -> (Cursor -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Cursor
cursor Cursor -> m ()
forall (m :: * -> *). MonadIO m => Cursor -> m ()
SDLE.setCursor
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleResetCursorIcon
:: MonomerM s e m
=> WidgetId
-> HandlerStep s e
-> m (HandlerStep s e)
handleResetCursorIcon :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetCursorIcon WidgetId
wid HandlerStep s e
previousStep = do
[(WidgetId, CursorIcon)]
cursors <- 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 m [(WidgetId, CursorIcon)]
-> ([(WidgetId, CursorIcon)] -> m [(WidgetId, CursorIcon)])
-> m [(WidgetId, CursorIcon)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetId -> [(WidgetId, CursorIcon)] -> m [(WidgetId, CursorIcon)]
forall s e (m :: * -> *) a.
MonomerM s e m =>
WidgetId -> [(WidgetId, a)] -> m [(WidgetId, a)]
dropNonParentWidgetId WidgetId
wid
let newCursors :: [(WidgetId, CursorIcon)]
newCursors = ((WidgetId, CursorIcon) -> Bool)
-> [(WidgetId, CursorIcon)] -> [(WidgetId, CursorIcon)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
==WidgetId
wid) (WidgetId -> Bool)
-> ((WidgetId, CursorIcon) -> WidgetId)
-> (WidgetId, CursorIcon)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId, CursorIcon) -> WidgetId
forall a b. (a, b) -> a
fst) [(WidgetId, CursorIcon)]
cursors
let newCursorIcon :: CursorIcon
newCursorIcon
| [(WidgetId, CursorIcon)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(WidgetId, CursorIcon)]
newCursors = CursorIcon
CursorArrow
| Bool
otherwise = (WidgetId, CursorIcon) -> CursorIcon
forall a b. (a, b) -> b
snd ((WidgetId, CursorIcon) -> CursorIcon)
-> ([(WidgetId, CursorIcon)] -> (WidgetId, CursorIcon))
-> [(WidgetId, CursorIcon)]
-> CursorIcon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(WidgetId, CursorIcon)] -> (WidgetId, CursorIcon)
forall a. [a] -> a
head ([(WidgetId, CursorIcon)] -> CursorIcon)
-> [(WidgetId, CursorIcon)] -> CursorIcon
forall a b. (a -> b) -> a -> b
$ [(WidgetId, CursorIcon)]
newCursors
([(WidgetId, CursorIcon)] -> Identity [(WidgetId, CursorIcon)])
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasCursorStack s a => Lens' s a
L.cursorStack (([(WidgetId, CursorIcon)] -> Identity [(WidgetId, CursorIcon)])
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> [(WidgetId, CursorIcon)] -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [(WidgetId, CursorIcon)]
newCursors
Cursor
cursor <- (Map CursorIcon Cursor -> CursorIcon -> Cursor
forall k a. Ord k => Map k a -> k -> a
Map.! CursorIcon
newCursorIcon) (Map CursorIcon Cursor -> Cursor)
-> m (Map CursorIcon Cursor) -> m Cursor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
(Map CursorIcon Cursor) (MonomerCtx s e) (Map CursorIcon Cursor)
-> m (Map CursorIcon Cursor)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Map CursorIcon Cursor) (MonomerCtx s e) (Map CursorIcon Cursor)
forall s a. HasCursorIcons s a => Lens' s a
L.cursorIcons
Cursor -> m ()
forall (m :: * -> *). MonadIO m => Cursor -> m ()
SDLE.setCursor Cursor
cursor
Maybe (Path, CursorIcon)
currentPair <- [(WidgetId, CursorIcon)] -> Maybe (WidgetId, CursorIcon)
forall a. [a] -> Maybe a
headMay [(WidgetId, CursorIcon)]
newCursors Maybe (WidgetId, CursorIcon)
-> (Maybe (WidgetId, CursorIcon) -> m (Maybe (Path, CursorIcon)))
-> m (Maybe (Path, CursorIcon))
forall a b. a -> (a -> b) -> b
& ((WidgetId, CursorIcon) -> m (Path, CursorIcon))
-> Maybe (WidgetId, CursorIcon) -> m (Maybe (Path, CursorIcon))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just (((WidgetId, CursorIcon) -> m (Path, CursorIcon))
-> Maybe (WidgetId, CursorIcon) -> m (Maybe (Path, CursorIcon)))
-> ((WidgetId -> m Path)
-> (WidgetId, CursorIcon) -> m (Path, CursorIcon))
-> (WidgetId -> m Path)
-> Maybe (WidgetId, CursorIcon)
-> m (Maybe (Path, CursorIcon))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> m Path)
-> (WidgetId, CursorIcon) -> m (Path, CursorIcon)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((WidgetId -> m Path)
-> Maybe (WidgetId, CursorIcon) -> m (Maybe (Path, CursorIcon)))
-> (WidgetId -> m Path)
-> Maybe (WidgetId, CursorIcon)
-> m (Maybe (Path, CursorIcon))
forall k (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlerStep s e -> m (HandlerStep s e))
-> HandlerStep s e -> m (HandlerStep s e)
forall a b. (a -> b) -> a -> b
$ HandlerStep s e
previousStep
HandlerStep s e
-> (HandlerStep s e -> HandlerStep s e) -> HandlerStep s e
forall a b. a -> (a -> b) -> b
& (WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> ((Maybe (Path, CursorIcon)
-> Identity (Maybe (Path, CursorIcon)))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Maybe (Path, CursorIcon)
-> Identity (Maybe (Path, CursorIcon)))
-> HandlerStep s e
-> Identity (HandlerStep s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Path, CursorIcon) -> Identity (Maybe (Path, CursorIcon)))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasCursor s a => Lens' s a
L.cursor ((Maybe (Path, CursorIcon) -> Identity (Maybe (Path, CursorIcon)))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> Maybe (Path, CursorIcon) -> HandlerStep s e -> HandlerStep s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Path, CursorIcon)
currentPair
handleStartDrag
:: MonomerM s e m
=> WidgetId
-> Path
-> WidgetDragMsg
-> HandlerStep s e
-> m (HandlerStep s e)
handleStartDrag :: WidgetId
-> Path -> WidgetDragMsg -> HandlerStep s e -> m (HandlerStep s e)
handleStartDrag WidgetId
widgetId Path
path WidgetDragMsg
dragData HandlerStep s e
previousStep = do
Maybe DragAction
oldDragAction <- 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
let prevWidgetId :: Maybe WidgetId
prevWidgetId = (DragAction -> WidgetId) -> Maybe DragAction -> Maybe WidgetId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DragAction -> Getting WidgetId DragAction WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. Getting WidgetId DragAction WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId) Maybe DragAction
oldDragAction
(Maybe DragAction -> Identity (Maybe DragAction))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasDragAction s a => Lens' s a
L.dragAction ((Maybe DragAction -> Identity (Maybe DragAction))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe DragAction -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= DragAction -> Maybe DragAction
forall a. a -> Maybe a
Just (WidgetId -> WidgetDragMsg -> DragAction
DragAction WidgetId
widgetId WidgetDragMsg
dragData)
WidgetId -> Path -> m ()
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> m ()
setWidgetIdPath WidgetId
widgetId Path
path
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlerStep s e -> m (HandlerStep s e))
-> HandlerStep s e -> m (HandlerStep s e)
forall a b. (a -> b) -> a -> b
$ HandlerStep s e
previousStep
HandlerStep s e
-> (HandlerStep s e -> HandlerStep s e) -> HandlerStep s e
forall a b. a -> (a -> b) -> b
& (WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> ((Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> HandlerStep s e
-> Identity (HandlerStep s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasDragStatus s a => Lens' s a
L.dragStatus ((Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> (Path, WidgetDragMsg) -> HandlerStep s e -> HandlerStep s e
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Path
path, WidgetDragMsg
dragData)
handleStopDrag
:: MonomerM s e m
=> WidgetId
-> HandlerStep s e
-> m (HandlerStep s e)
handleStopDrag :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleStopDrag WidgetId
widgetId HandlerStep s e
previousStep = do
Maybe DragAction
oldDragAction <- 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
let prevWidgetId :: Maybe WidgetId
prevWidgetId = (DragAction -> WidgetId) -> Maybe DragAction -> Maybe WidgetId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DragAction -> Getting WidgetId DragAction WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. Getting WidgetId DragAction WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId) Maybe DragAction
oldDragAction
if Maybe WidgetId
prevWidgetId Maybe WidgetId -> Maybe WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId -> Maybe WidgetId
forall a. a -> Maybe a
Just WidgetId
widgetId
then do
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
(Maybe DragAction -> Identity (Maybe DragAction))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasDragAction s a => Lens' s a
L.dragAction ((Maybe DragAction -> Identity (Maybe DragAction))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe DragAction -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe DragAction
forall a. Maybe a
Nothing
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlerStep s e -> m (HandlerStep s e))
-> HandlerStep s e -> m (HandlerStep s e)
forall a b. (a -> b) -> a -> b
$ HandlerStep s e
previousStep
HandlerStep s e
-> (HandlerStep s e -> HandlerStep s e) -> HandlerStep s e
forall a b. a -> (a -> b) -> b
& (WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> ((Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> HandlerStep s e
-> Identity (HandlerStep s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasDragStatus s a => Lens' s a
L.dragStatus ((Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> Maybe (Path, WidgetDragMsg)
-> HandlerStep s e
-> HandlerStep s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Path, WidgetDragMsg)
forall a. Maybe a
Nothing
else HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleFinalizeDrop
:: MonomerM s e m
=> HandlerStep s e
-> m (HandlerStep s e)
handleFinalizeDrop :: HandlerStep s e -> m (HandlerStep s e)
handleFinalizeDrop HandlerStep s e
previousStep = 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
let widgetId :: Maybe WidgetId
widgetId = (DragAction -> WidgetId) -> Maybe DragAction -> Maybe WidgetId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DragAction -> Getting WidgetId DragAction WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. Getting WidgetId DragAction WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId) Maybe DragAction
dragAction
if Maybe WidgetId -> Bool
forall a. Maybe a -> Bool
isJust Maybe WidgetId
widgetId
then do
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
(Maybe DragAction -> Identity (Maybe DragAction))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasDragAction s a => Lens' s a
L.dragAction ((Maybe DragAction -> Identity (Maybe DragAction))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe DragAction -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe DragAction
forall a. Maybe a
Nothing
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (HandlerStep s e -> m (HandlerStep s e))
-> HandlerStep s e -> m (HandlerStep s e)
forall a b. (a -> b) -> a -> b
$ HandlerStep s e
previousStep
HandlerStep s e
-> (HandlerStep s e -> HandlerStep s e) -> HandlerStep s e
forall a b. a -> (a -> b) -> b
& (WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((WidgetEnv s e -> Identity (WidgetEnv s e))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> ((Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> HandlerStep s e
-> Identity (HandlerStep s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasDragStatus s a => Lens' s a
L.dragStatus ((Maybe (Path, WidgetDragMsg)
-> Identity (Maybe (Path, WidgetDragMsg)))
-> HandlerStep s e -> Identity (HandlerStep s e))
-> Maybe (Path, WidgetDragMsg)
-> HandlerStep s e
-> HandlerStep s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Path, WidgetDragMsg)
forall a. Maybe a
Nothing
else HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleRenderOnce :: MonomerM s e m => HandlerStep s e -> m (HandlerStep s e)
handleRenderOnce :: HandlerStep s e -> m (HandlerStep s e)
handleRenderOnce HandlerStep s e
previousStep = do
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleRenderEvery
:: MonomerM s e m
=> WidgetId
-> Int
-> Maybe Int
-> HandlerStep s e
-> m (HandlerStep s e)
handleRenderEvery :: WidgetId
-> Int -> Maybe Int -> HandlerStep s e -> m (HandlerStep s e)
handleRenderEvery WidgetId
widgetId Int
ms Maybe Int
repeat HandlerStep s e
previousStep = do
Map WidgetId RenderSchedule
schedule <- Getting
(Map WidgetId RenderSchedule)
(MonomerCtx s e)
(Map WidgetId RenderSchedule)
-> m (Map WidgetId RenderSchedule)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Map WidgetId RenderSchedule)
(MonomerCtx s e)
(Map WidgetId RenderSchedule)
forall s a. HasRenderSchedule s a => Lens' s a
L.renderSchedule
(Map WidgetId RenderSchedule
-> Identity (Map WidgetId RenderSchedule))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderSchedule s a => Lens' s a
L.renderSchedule ((Map WidgetId RenderSchedule
-> Identity (Map WidgetId RenderSchedule))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Map WidgetId RenderSchedule -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Map WidgetId RenderSchedule -> Map WidgetId RenderSchedule
addSchedule Map WidgetId RenderSchedule
schedule
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
where
(WidgetEnv s e
wenv, WidgetNode s e
_, Seq (WidgetRequest s e)
_) = HandlerStep s e
previousStep
newValue :: RenderSchedule
newValue = RenderSchedule :: WidgetId -> Int -> Int -> Maybe Int -> RenderSchedule
RenderSchedule {
_rsWidgetId :: WidgetId
_rsWidgetId = WidgetId
widgetId,
_rsStart :: Int
_rsStart = WidgetEnv s e -> Int
forall s e. WidgetEnv s e -> Int
_weTimestamp WidgetEnv s e
wenv,
_rsMs :: Int
_rsMs = Int
ms,
_rsRepeat :: Maybe Int
_rsRepeat = Maybe Int
repeat
}
addSchedule :: Map WidgetId RenderSchedule -> Map WidgetId RenderSchedule
addSchedule Map WidgetId RenderSchedule
schedule
| Int
ms Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = WidgetId
-> RenderSchedule
-> Map WidgetId RenderSchedule
-> Map WidgetId RenderSchedule
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert WidgetId
widgetId RenderSchedule
newValue Map WidgetId RenderSchedule
schedule
| Bool
otherwise = Map WidgetId RenderSchedule
schedule
handleRenderStop
:: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleRenderStop :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleRenderStop WidgetId
widgetId HandlerStep s e
previousStep = do
Map WidgetId RenderSchedule
schedule <- Getting
(Map WidgetId RenderSchedule)
(MonomerCtx s e)
(Map WidgetId RenderSchedule)
-> m (Map WidgetId RenderSchedule)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Map WidgetId RenderSchedule)
(MonomerCtx s e)
(Map WidgetId RenderSchedule)
forall s a. HasRenderSchedule s a => Lens' s a
L.renderSchedule
(Map WidgetId RenderSchedule
-> Identity (Map WidgetId RenderSchedule))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderSchedule s a => Lens' s a
L.renderSchedule ((Map WidgetId RenderSchedule
-> Identity (Map WidgetId RenderSchedule))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Map WidgetId RenderSchedule -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetId
-> Map WidgetId RenderSchedule -> Map WidgetId RenderSchedule
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete WidgetId
widgetId Map WidgetId RenderSchedule
schedule
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleRemoveRendererImage
:: MonomerM s e m => Text -> HandlerStep s e -> m (HandlerStep s e)
handleRemoveRendererImage :: Text -> HandlerStep s e -> m (HandlerStep s e)
handleRemoveRendererImage Text
name HandlerStep s e
previousStep = do
TChan (RenderMsg s e)
renderChannel <- Getting
(TChan (RenderMsg s e)) (MonomerCtx s e) (TChan (RenderMsg s e))
-> m (TChan (RenderMsg s e))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(TChan (RenderMsg s e)) (MonomerCtx s e) (TChan (RenderMsg s e))
forall s a. HasRenderChannel s a => Lens' s a
L.renderChannel
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (STM () -> IO ()) -> STM () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TChan (RenderMsg s e) -> RenderMsg s e -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (RenderMsg s e)
renderChannel (Text -> RenderMsg s e
forall s e. Text -> RenderMsg s e
MsgRemoveImage Text
name)
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleExitApplication
:: MonomerM s e m => Bool -> HandlerStep s e -> m (HandlerStep s e)
handleExitApplication :: Bool -> HandlerStep s e -> m (HandlerStep s e)
handleExitApplication Bool
exit HandlerStep s e
previousStep = do
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasExitApplication s a => Lens' s a
L.exitApplication ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
exit
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleUpdateWindow
:: MonomerM s e m => WindowRequest -> HandlerStep s e -> m (HandlerStep s e)
handleUpdateWindow :: WindowRequest -> HandlerStep s e -> m (HandlerStep s e)
handleUpdateWindow WindowRequest
windowRequest HandlerStep s e
previousStep = do
Window
window <- Getting Window (MonomerCtx s e) Window -> m Window
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Window (MonomerCtx s e) Window
forall s a. HasWindow s a => Lens' s a
L.window
case WindowRequest
windowRequest of
WindowSetTitle Text
title -> Window -> StateVar Text
SDL.windowTitle Window
window StateVar Text -> Text -> m ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Text
title
WindowRequest
WindowSetFullScreen -> Window -> WindowMode -> m ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.FullscreenDesktop
WindowRequest
WindowMaximize -> Window -> WindowMode -> m ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.Maximized
WindowRequest
WindowMinimize -> Window -> WindowMode -> m ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.Minimized
WindowRequest
WindowRestore -> Window -> WindowMode -> m ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.Windowed
WindowRequest
WindowBringToFront -> Window -> m ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.raiseWindow Window
window
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleUpdateModel
:: MonomerM s e m => (s -> s) -> HandlerStep s e -> m (HandlerStep s e)
handleUpdateModel :: (s -> s) -> HandlerStep s e -> m (HandlerStep s e)
handleUpdateModel s -> s
fn (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = do
(s -> Identity s) -> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasMainModel s a => Lens' s a
L.mainModel ((s -> Identity s) -> MonomerCtx s e -> Identity (MonomerCtx s e))
-> s -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= WidgetEnv s e -> s
forall s e. WidgetEnv s e -> s
_weModel WidgetEnv s e
wenv2
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
wenv2, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs)
where
wenv2 :: WidgetEnv s e
wenv2 = WidgetEnv s e
wenv WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (s -> Identity s) -> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasModel s a => Lens' s a
L.model ((s -> Identity s) -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (s -> s) -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ s -> s
fn
handleSetWidgetPath
:: MonomerM s e m => WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e)
handleSetWidgetPath :: WidgetId -> Path -> HandlerStep s e -> m (HandlerStep s e)
handleSetWidgetPath WidgetId
wid Path
path HandlerStep s e
step = do
WidgetId -> Path -> m ()
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> m ()
setWidgetIdPath WidgetId
wid Path
path
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
handleResetWidgetPath
:: MonomerM s e m => WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetWidgetPath :: WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetWidgetPath WidgetId
wid HandlerStep s e
step = do
WidgetId -> m ()
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m ()
delWidgetIdPath WidgetId
wid
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
handleRaiseEvent
:: forall s e m msg . (MonomerM s e m, Typeable msg)
=> msg
-> HandlerStep s e
-> m (HandlerStep s e)
handleRaiseEvent :: msg -> HandlerStep s e -> m (HandlerStep s e)
handleRaiseEvent msg
message HandlerStep s e
step = do
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
step
where
message :: String
message = String
"Invalid state. RaiseEvent reached main handler. Type: "
handleSendMessage
:: forall s e m msg . (MonomerM s e m, Typeable msg)
=> WidgetId
-> msg
-> HandlerStep s e
-> m (HandlerStep s e)
handleSendMessage :: WidgetId -> msg -> HandlerStep s e -> m (HandlerStep s e)
handleSendMessage WidgetId
widgetId msg
message (WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
reqs) = do
Path
path <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
widgetId
let emptyResult :: WidgetResult s e
emptyResult = WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
forall s e.
WidgetNode s e -> Seq (WidgetRequest s e) -> WidgetResult s e
WidgetResult WidgetNode s e
root Seq (WidgetRequest s e)
forall a. Seq a
Seq.empty
let widget :: Widget s e
widget = WidgetNode s e
root WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let msgResult :: Maybe (WidgetResult s e)
msgResult = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> msg
-> Maybe (WidgetResult s e)
forall s e.
Widget s e
-> forall i.
Typeable i =>
WidgetEnv s e
-> WidgetNode s e -> Path -> i -> Maybe (WidgetResult s e)
widgetHandleMessage Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
root Path
path msg
message
let result :: WidgetResult s e
result = WidgetResult s e -> Maybe (WidgetResult s e) -> WidgetResult s e
forall a. a -> Maybe a -> a
fromMaybe WidgetResult s e
emptyResult Maybe (WidgetResult s e)
msgResult
(WidgetEnv s e
newWenv, WidgetNode s e
newRoot, Seq (WidgetRequest s e)
newReqs) <- WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e -> Bool -> WidgetResult s e -> m (HandlerStep s e)
handleWidgetResult WidgetEnv s e
wenv Bool
True WidgetResult s e
result
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetEnv s e
newWenv, WidgetNode s e
newRoot, Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
forall a. Semigroup a => a -> a -> a
<> Seq (WidgetRequest s e)
newReqs)
handleRunTask
:: forall s e m i . (MonomerM s e m, Typeable i)
=> WidgetId
-> Path
-> IO i
-> HandlerStep s e
-> m (HandlerStep s e)
handleRunTask :: WidgetId -> Path -> IO i -> HandlerStep s e -> m (HandlerStep s e)
handleRunTask WidgetId
widgetId Path
path IO i
handler HandlerStep s e
previousStep = do
Async i
asyncTask <- IO (Async i) -> m (Async i)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async i) -> m (Async i)) -> IO (Async i) -> m (Async i)
forall a b. (a -> b) -> a -> b
$ IO i -> IO (Async i)
forall a. IO a -> IO (Async a)
async (IO i -> IO i
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO i
handler)
Seq WidgetTask
previousTasks <- Getting (Seq WidgetTask) (MonomerCtx s e) (Seq WidgetTask)
-> m (Seq WidgetTask)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Seq WidgetTask) (MonomerCtx s e) (Seq WidgetTask)
forall s a. HasWidgetTasks s a => Lens' s a
L.widgetTasks
(Seq WidgetTask -> Identity (Seq WidgetTask))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasWidgetTasks s a => Lens' s a
L.widgetTasks ((Seq WidgetTask -> Identity (Seq WidgetTask))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Seq WidgetTask -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Seq WidgetTask
previousTasks Seq WidgetTask -> WidgetTask -> Seq WidgetTask
forall a. Seq a -> a -> Seq a
|> WidgetId -> Async i -> WidgetTask
forall i. Typeable i => WidgetId -> Async i -> WidgetTask
WidgetTask WidgetId
widgetId Async i
asyncTask
WidgetId -> Path -> m ()
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> m ()
setWidgetIdPath WidgetId
widgetId Path
path
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
handleRunProducer
:: forall s e m i . (MonomerM s e m, Typeable i)
=> WidgetId
-> Path
-> ((i -> IO ()) -> IO ())
-> HandlerStep s e
-> m (HandlerStep s e)
handleRunProducer :: WidgetId
-> Path
-> ((i -> IO ()) -> IO ())
-> HandlerStep s e
-> m (HandlerStep s e)
handleRunProducer WidgetId
widgetId Path
path (i -> IO ()) -> IO ()
handler HandlerStep s e
previousStep = do
TChan i
newChannel <- IO (TChan i) -> m (TChan i)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TChan i)
forall a. IO (TChan a)
newTChanIO
Async ()
asyncTask <- IO (Async ()) -> m (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> m (Async ())) -> IO (Async ()) -> m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (i -> IO ()) -> IO ()
handler (TChan i -> i -> IO ()
forall e. TChan e -> e -> IO ()
sendMessage TChan i
newChannel))
Seq WidgetTask
previousTasks <- Getting (Seq WidgetTask) (MonomerCtx s e) (Seq WidgetTask)
-> m (Seq WidgetTask)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Seq WidgetTask) (MonomerCtx s e) (Seq WidgetTask)
forall s a. HasWidgetTasks s a => Lens' s a
L.widgetTasks
(Seq WidgetTask -> Identity (Seq WidgetTask))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasWidgetTasks s a => Lens' s a
L.widgetTasks ((Seq WidgetTask -> Identity (Seq WidgetTask))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Seq WidgetTask -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Seq WidgetTask
previousTasks Seq WidgetTask -> WidgetTask -> Seq WidgetTask
forall a. Seq a -> a -> Seq a
|> WidgetId -> TChan i -> Async () -> WidgetTask
forall i.
Typeable i =>
WidgetId -> TChan i -> Async () -> WidgetTask
WidgetProducer WidgetId
widgetId TChan i
newChannel Async ()
asyncTask
WidgetId -> Path -> m ()
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> Path -> m ()
setWidgetIdPath WidgetId
widgetId Path
path
HandlerStep s e -> m (HandlerStep s e)
forall (m :: * -> *) a. Monad m => a -> m a
return HandlerStep s e
previousStep
sendMessage :: TChan e -> e -> IO ()
sendMessage :: TChan e -> e -> IO ()
sendMessage TChan e
channel e
message = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan e -> e -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan e
channel e
message
addFocusReq
:: SystemEvent
-> Seq (WidgetRequest s e)
-> Seq (WidgetRequest s e)
addFocusReq :: SystemEvent -> Seq (WidgetRequest s e) -> Seq (WidgetRequest s e)
addFocusReq (KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed) Seq (WidgetRequest s e)
reqs = Seq (WidgetRequest s e)
newReqs where
isTabPressed :: Bool
isTabPressed = KeyCode -> Bool
isKeyTab KeyCode
code
stopProcessing :: Bool
stopProcessing = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ (WidgetRequest s e -> Bool) -> Seq (WidgetRequest s e) -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
Seq.findIndexL WidgetRequest s e -> Bool
forall s e. WidgetRequest s e -> Bool
isIgnoreParentEvents Seq (WidgetRequest s e)
reqs
focusReqExists :: Bool
focusReqExists = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ (WidgetRequest s e -> Bool) -> Seq (WidgetRequest s e) -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
Seq.findIndexL WidgetRequest s e -> Bool
forall s e. WidgetRequest s e -> Bool
isFocusRequest Seq (WidgetRequest s e)
reqs
focusReqNeeded :: Bool
focusReqNeeded = Bool
isTabPressed Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
stopProcessing Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
focusReqExists
direction :: FocusDirection
direction
| KeyMod
mod KeyMod -> Getting Bool KeyMod Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyMod Bool
forall s a. HasLeftShift s a => Lens' s a
L.leftShift = FocusDirection
FocusBwd
| Bool
otherwise = FocusDirection
FocusFwd
newReqs :: Seq (WidgetRequest s e)
newReqs
| Bool
focusReqNeeded = Seq (WidgetRequest s e)
reqs Seq (WidgetRequest s e)
-> WidgetRequest s e -> Seq (WidgetRequest s e)
forall a. Seq a -> a -> Seq a
|> Maybe WidgetId -> FocusDirection -> WidgetRequest s e
forall s e. Maybe WidgetId -> FocusDirection -> WidgetRequest s e
MoveFocus Maybe WidgetId
forall a. Maybe a
Nothing FocusDirection
direction
| Bool
otherwise = Seq (WidgetRequest s e)
reqs
addFocusReq SystemEvent
_ Seq (WidgetRequest s e)
reqs = Seq (WidgetRequest s e)
reqs
preProcessEvents :: [SystemEvent] -> [SystemEvent]
preProcessEvents :: [SystemEvent] -> [SystemEvent]
preProcessEvents [] = []
preProcessEvents (SystemEvent
e:[SystemEvent]
es) = case SystemEvent
e of
WheelScroll Point
p Point
_ WheelDirection
_ -> SystemEvent
e SystemEvent -> [SystemEvent] -> [SystemEvent]
forall a. a -> [a] -> [a]
: Point -> SystemEvent
Move Point
p SystemEvent -> [SystemEvent] -> [SystemEvent]
forall a. a -> [a] -> [a]
: [SystemEvent] -> [SystemEvent]
preProcessEvents [SystemEvent]
es
SystemEvent
_ -> SystemEvent
e SystemEvent -> [SystemEvent] -> [SystemEvent]
forall a. a -> [a] -> [a]
: [SystemEvent] -> [SystemEvent]
preProcessEvents [SystemEvent]
es
addRelatedEvents
:: MonomerM s e m
=> WidgetEnv s e
-> Button
-> WidgetNode s e
-> SystemEvent
-> m [(SystemEvent, Maybe Path)]
addRelatedEvents :: WidgetEnv s e
-> Button
-> WidgetNode s e
-> SystemEvent
-> m [(SystemEvent, Maybe Path)]
addRelatedEvents WidgetEnv s e
wenv Button
mainBtn WidgetNode s e
widgetRoot SystemEvent
evt = case SystemEvent
evt of
Move Point
point -> do
(Maybe Path
target, [(SystemEvent, Maybe Path)]
hoverEvts) <- WidgetEnv s e
-> WidgetNode s e
-> Point
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e
-> Point
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
addHoverEvents WidgetEnv s e
wenv WidgetNode s e
widgetRoot Point
point
InputStatus
status <- Getting InputStatus (MonomerCtx s e) InputStatus -> m InputStatus
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting InputStatus (MonomerCtx s e) InputStatus
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus
(InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Point -> Identity Point)
-> InputStatus -> Identity InputStatus)
-> (Point -> Identity Point)
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Identity Point) -> InputStatus -> Identity InputStatus
forall s a. HasMousePosPrev s a => Lens' s a
L.mousePosPrev ((Point -> Identity Point)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Point -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= InputStatus
status InputStatus
-> ((Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus)
-> Point
forall s a. s -> Getting a s a -> a
^. (Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus
forall s a. HasMousePos s a => Lens' s a
L.mousePos
(InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Point -> Identity Point)
-> InputStatus -> Identity InputStatus)
-> (Point -> Identity Point)
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Identity Point) -> InputStatus -> Identity InputStatus
forall s a. HasMousePos s a => Lens' s a
L.mousePos ((Point -> Identity Point)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Point -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Point
point
Maybe (Path, Point)
mainPress <- Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
-> m (Maybe (Path, Point))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
Maybe (Path, WidgetDragMsg)
draggedMsg <- m (Maybe (Path, WidgetDragMsg))
forall s e (m :: * -> *).
MonomerM s e m =>
m (Maybe (Path, WidgetDragMsg))
getDraggedMsgInfo
let pressed :: Maybe Path
pressed = ((Path, Point) -> Path) -> Maybe (Path, Point) -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path, Point) -> Path
forall a b. (a, b) -> a
fst Maybe (Path, Point)
mainPress
let isPressed :: Bool
isPressed = Maybe Path
target Maybe Path -> Maybe Path -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Path
pressed
let dragEvts :: [(SystemEvent, Maybe Path)]
dragEvts = case Maybe (Path, WidgetDragMsg)
draggedMsg of
Just (Path
path, WidgetDragMsg
msg) -> [(Point -> Path -> WidgetDragMsg -> SystemEvent
Drag Point
point Path
path WidgetDragMsg
msg, Maybe Path
target) | Bool -> Bool
not Bool
isPressed]
Maybe (Path, WidgetDragMsg)
_ -> []
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Path, Point) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Path, Point)
mainPress Bool -> Bool -> Bool
|| Maybe (Path, WidgetDragMsg) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Path, WidgetDragMsg)
draggedMsg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasRenderRequested s a => Lens' s a
L.renderRequested ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
[(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)])
-> [(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall a b. (a -> b) -> a -> b
$ [(SystemEvent, Maybe Path)]
hoverEvts [(SystemEvent, Maybe Path)]
-> [(SystemEvent, Maybe Path)] -> [(SystemEvent, Maybe Path)]
forall a. [a] -> [a] -> [a]
++ [(SystemEvent, Maybe Path)]
dragEvts [(SystemEvent, Maybe Path)]
-> [(SystemEvent, Maybe Path)] -> [(SystemEvent, Maybe Path)]
forall a. [a] -> [a] -> [a]
++ [(SystemEvent
evt, Maybe Path
forall a. Maybe a
Nothing)]
ButtonAction Point
point Button
btn ButtonState
BtnPressed Int
_ -> do
Maybe Path
overlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
let start :: Path
start = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
emptyPath Maybe Path
overlay
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let wni :: Maybe WidgetNodeInfo
wni = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot Path
start Point
point
let curr :: Maybe Path
curr = (WidgetNodeInfo -> Path) -> Maybe WidgetNodeInfo -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WidgetNodeInfo -> Getting Path WidgetNodeInfo Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetNodeInfo Path
forall s a. HasPath s a => Lens' s a
L.path) Maybe WidgetNodeInfo
wni
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
mainBtn) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
(Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress ((Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe (Path, Point) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (Path -> (Path, Point)) -> Maybe Path -> Maybe (Path, Point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Point
point) Maybe Path
curr
(InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe ButtonState -> Identity (Maybe ButtonState))
-> InputStatus -> Identity InputStatus)
-> (Maybe ButtonState -> Identity (Maybe ButtonState))
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Button ButtonState -> Identity (Map Button ButtonState))
-> InputStatus -> Identity InputStatus
forall s a. HasButtons s a => Lens' s a
L.buttons ((Map Button ButtonState -> Identity (Map Button ButtonState))
-> InputStatus -> Identity InputStatus)
-> ((Maybe ButtonState -> Identity (Maybe ButtonState))
-> Map Button ButtonState -> Identity (Map Button ButtonState))
-> (Maybe ButtonState -> Identity (Maybe ButtonState))
-> InputStatus
-> Identity InputStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Button ButtonState)
-> Lens'
(Map Button ButtonState) (Maybe (IxValue (Map Button ButtonState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Button ButtonState)
Button
btn ((Maybe ButtonState -> Identity (Maybe ButtonState))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ButtonState -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= ButtonState
BtnPressed
Bool -> m CInt
forall (m :: * -> *). MonadIO m => Bool -> m CInt
SDLE.captureMouse Bool
True
[(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SystemEvent
evt, Maybe Path
forall a. Maybe a
Nothing)]
ButtonAction Point
point Button
btn ButtonState
BtnReleased Int
clicks -> do
Maybe (Path, Point)
mainPress <- Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
-> m (Maybe (Path, Point))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
Maybe (Path, WidgetDragMsg)
draggedMsg <- m (Maybe (Path, WidgetDragMsg))
forall s e (m :: * -> *).
MonomerM s e m =>
m (Maybe (Path, WidgetDragMsg))
getDraggedMsgInfo
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
mainBtn) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
(Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress ((Maybe (Path, Point) -> Identity (Maybe (Path, Point)))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Maybe (Path, Point) -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe (Path, Point)
forall a. Maybe a
Nothing
(Maybe Path
target, [(SystemEvent, Maybe Path)]
hoverEvts) <- WidgetEnv s e
-> WidgetNode s e
-> Point
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e
-> Point
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
addHoverEvents WidgetEnv s e
wenv WidgetNode s e
widgetRoot Point
point
let pressed :: Maybe Path
pressed = ((Path, Point) -> Path) -> Maybe (Path, Point) -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path, Point) -> Path
forall a b. (a, b) -> a
fst Maybe (Path, Point)
mainPress
let isPressed :: Bool
isPressed = Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
mainBtn Bool -> Bool -> Bool
&& Maybe Path
target Maybe Path -> Maybe Path -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Path
pressed
let clickEvt :: [(SystemEvent, Maybe Path)]
clickEvt = [(Point -> Button -> Int -> SystemEvent
Click Point
point Button
btn Int
clicks, Maybe Path
pressed) | Bool
isPressed Bool -> Bool -> Bool
|| Int
clicks Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1]
let releasedEvt :: [(SystemEvent, Maybe Path)]
releasedEvt = [(SystemEvent
evt, Maybe Path
pressed Maybe Path -> Maybe Path -> Maybe Path
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Path
target)]
let dropEvts :: [(SystemEvent, Maybe Path)]
dropEvts = case Maybe (Path, WidgetDragMsg)
draggedMsg of
Just (Path
path, WidgetDragMsg
msg) -> [(Point -> Path -> WidgetDragMsg -> SystemEvent
Drop Point
point Path
path WidgetDragMsg
msg, Maybe Path
target) | Bool -> Bool
not Bool
isPressed]
Maybe (Path, WidgetDragMsg)
_ -> []
(InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe ButtonState -> Identity (Maybe ButtonState))
-> InputStatus -> Identity InputStatus)
-> (Maybe ButtonState -> Identity (Maybe ButtonState))
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Button ButtonState -> Identity (Map Button ButtonState))
-> InputStatus -> Identity InputStatus
forall s a. HasButtons s a => Lens' s a
L.buttons ((Map Button ButtonState -> Identity (Map Button ButtonState))
-> InputStatus -> Identity InputStatus)
-> ((Maybe ButtonState -> Identity (Maybe ButtonState))
-> Map Button ButtonState -> Identity (Map Button ButtonState))
-> (Maybe ButtonState -> Identity (Maybe ButtonState))
-> InputStatus
-> Identity InputStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Button ButtonState)
-> Lens'
(Map Button ButtonState) (Maybe (IxValue (Map Button ButtonState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Button ButtonState)
Button
btn ((Maybe ButtonState -> Identity (Maybe ButtonState))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ButtonState -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= ButtonState
BtnReleased
Bool -> m CInt
forall (m :: * -> *). MonadIO m => Bool -> m CInt
SDLE.captureMouse Bool
False
[(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)])
-> [(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall a b. (a -> b) -> a -> b
$ [(SystemEvent, Maybe Path)]
releasedEvt [(SystemEvent, Maybe Path)]
-> [(SystemEvent, Maybe Path)] -> [(SystemEvent, Maybe Path)]
forall a. [a] -> [a] -> [a]
++ [(SystemEvent, Maybe Path)]
dropEvts [(SystemEvent, Maybe Path)]
-> [(SystemEvent, Maybe Path)] -> [(SystemEvent, Maybe Path)]
forall a. [a] -> [a] -> [a]
++ [(SystemEvent, Maybe Path)]
clickEvt [(SystemEvent, Maybe Path)]
-> [(SystemEvent, Maybe Path)] -> [(SystemEvent, Maybe Path)]
forall a. [a] -> [a] -> [a]
++ [(SystemEvent, Maybe Path)]
hoverEvts
KeyAction KeyMod
mod KeyCode
code KeyStatus
status -> do
(InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((KeyMod -> Identity KeyMod)
-> InputStatus -> Identity InputStatus)
-> (KeyMod -> Identity KeyMod)
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMod -> Identity KeyMod) -> InputStatus -> Identity InputStatus
forall s a. HasKeyMod s a => Lens' s a
L.keyMod ((KeyMod -> Identity KeyMod)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> KeyMod -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= KeyMod
mod
(InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus ((InputStatus -> Identity InputStatus)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> ((Maybe KeyStatus -> Identity (Maybe KeyStatus))
-> InputStatus -> Identity InputStatus)
-> (Maybe KeyStatus -> Identity (Maybe KeyStatus))
-> MonomerCtx s e
-> Identity (MonomerCtx s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map KeyCode KeyStatus -> Identity (Map KeyCode KeyStatus))
-> InputStatus -> Identity InputStatus
forall s a. HasKeys s a => Lens' s a
L.keys ((Map KeyCode KeyStatus -> Identity (Map KeyCode KeyStatus))
-> InputStatus -> Identity InputStatus)
-> ((Maybe KeyStatus -> Identity (Maybe KeyStatus))
-> Map KeyCode KeyStatus -> Identity (Map KeyCode KeyStatus))
-> (Maybe KeyStatus -> Identity (Maybe KeyStatus))
-> InputStatus
-> Identity InputStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map KeyCode KeyStatus)
-> Lens'
(Map KeyCode KeyStatus) (Maybe (IxValue (Map KeyCode KeyStatus)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map KeyCode KeyStatus)
KeyCode
code ((Maybe KeyStatus -> Identity (Maybe KeyStatus))
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> KeyStatus -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= KeyStatus
status
[(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SystemEvent
evt, Maybe Path
forall a. Maybe a
Nothing)]
Click Point
point Button
btn Int
clicks -> WidgetEnv s e
-> WidgetNode s e
-> SystemEvent
-> Point
-> m [(SystemEvent, Maybe Path)]
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetEnv s e
-> WidgetNode s e
-> SystemEvent
-> Point
-> m [(SystemEvent, Maybe Path)]
findEvtTargetByPoint WidgetEnv s e
wenv WidgetNode s e
widgetRoot SystemEvent
evt Point
point
SystemEvent
_ -> [(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SystemEvent
evt, Maybe Path
forall a. Maybe a
Nothing)]
addHoverEvents
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> Point
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
addHoverEvents :: WidgetEnv s e
-> WidgetNode s e
-> Point
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
addHoverEvents WidgetEnv s e
wenv WidgetNode s e
widgetRoot Point
point = do
Maybe Path
overlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
Maybe Path
hover <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getHoveredPath
Maybe (Path, Point)
mainBtnPress <- Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
-> m (Maybe (Path, Point))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Maybe (Path, Point)) (MonomerCtx s e) (Maybe (Path, Point))
forall s a. HasMainBtnPress s a => Lens' s a
L.mainBtnPress
let start :: Path
start = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
emptyPath Maybe Path
overlay
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let wni :: Maybe WidgetNodeInfo
wni = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot Path
start Point
point
let target :: Maybe Path
target = (WidgetNodeInfo -> Path) -> Maybe WidgetNodeInfo -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WidgetNodeInfo -> Getting Path WidgetNodeInfo Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetNodeInfo Path
forall s a. HasPath s a => Lens' s a
L.path) Maybe WidgetNodeInfo
wni
let hoverChanged :: Bool
hoverChanged = Maybe Path
target Maybe Path -> Maybe Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Path
hover Bool -> Bool -> Bool
&& Maybe (Path, Point) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Path, Point)
mainBtnPress
let enter :: [(SystemEvent, Maybe Path)]
enter = [(Point -> SystemEvent
Enter Point
point, Maybe Path
target) | Maybe Path -> Bool
forall a. Maybe a -> Bool
isJust Maybe Path
target Bool -> Bool -> Bool
&& Bool
hoverChanged]
let leave :: [(SystemEvent, Maybe Path)]
leave = [(Point -> SystemEvent
Leave Point
point, Maybe Path
hover) | Maybe Path -> Bool
forall a. Maybe a -> Bool
isJust Maybe Path
hover Bool -> Bool -> Bool
&& Bool
hoverChanged]
(Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e)
forall s a. HasLeaveEnterPair s a => Lens' s a
L.leaveEnterPair ((Bool -> Identity Bool)
-> MonomerCtx s e -> Identity (MonomerCtx s e))
-> Bool -> m ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool -> Bool
not ([(SystemEvent, Maybe Path)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SystemEvent, Maybe Path)]
leave Bool -> Bool -> Bool
|| [(SystemEvent, Maybe Path)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SystemEvent, Maybe Path)]
enter)
(Maybe Path, [(SystemEvent, Maybe Path)])
-> m (Maybe Path, [(SystemEvent, Maybe Path)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Path
target, [(SystemEvent, Maybe Path)]
leave [(SystemEvent, Maybe Path)]
-> [(SystemEvent, Maybe Path)] -> [(SystemEvent, Maybe Path)]
forall a. [a] -> [a] -> [a]
++ [(SystemEvent, Maybe Path)]
enter)
findEvtTargetByPoint
:: MonomerM s e m
=> WidgetEnv s e
-> WidgetNode s e
-> SystemEvent
-> Point
-> m [(SystemEvent, Maybe Path)]
findEvtTargetByPoint :: WidgetEnv s e
-> WidgetNode s e
-> SystemEvent
-> Point
-> m [(SystemEvent, Maybe Path)]
findEvtTargetByPoint WidgetEnv s e
wenv WidgetNode s e
widgetRoot SystemEvent
evt Point
point = do
Maybe Path
overlay <- m (Maybe Path)
forall s e (m :: * -> *). MonomerM s e m => m (Maybe Path)
getOverlayPath
let start :: Path
start = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
emptyPath Maybe Path
overlay
let widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
let wni :: Maybe WidgetNodeInfo
wni = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot Path
start Point
point
let curr :: Maybe Path
curr = (WidgetNodeInfo -> Path) -> Maybe WidgetNodeInfo -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WidgetNodeInfo -> Getting Path WidgetNodeInfo Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetNodeInfo Path
forall s a. HasPath s a => Lens' s a
L.path) Maybe WidgetNodeInfo
wni
[(SystemEvent, Maybe Path)] -> m [(SystemEvent, Maybe Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SystemEvent
evt, Maybe Path
curr)]
findNextFocus
:: WidgetEnv s e
-> FocusDirection
-> Path
-> Maybe Path
-> WidgetNode s e
-> WidgetNodeInfo
findNextFocus :: WidgetEnv s e
-> FocusDirection
-> Path
-> Maybe Path
-> WidgetNode s e
-> WidgetNodeInfo
findNextFocus WidgetEnv s e
wenv FocusDirection
dir Path
start Maybe Path
overlay WidgetNode s e
widgetRoot = Maybe WidgetNodeInfo -> WidgetNodeInfo
forall a. HasCallStack => Maybe a -> a
fromJust Maybe WidgetNodeInfo
nextFocus where
widget :: Widget s e
widget = WidgetNode s e
widgetRoot WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
restartPath :: Path
restartPath = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
emptyPath Maybe Path
overlay
candidateWni :: Maybe WidgetNodeInfo
candidateWni = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> FocusDirection
-> Path
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> FocusDirection
-> Path
-> Maybe WidgetNodeInfo
widgetFindNextFocus Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot FocusDirection
dir Path
start
fromRootWni :: Maybe WidgetNodeInfo
fromRootWni = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> FocusDirection
-> Path
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> FocusDirection
-> Path
-> Maybe WidgetNodeInfo
widgetFindNextFocus Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
widgetRoot FocusDirection
dir Path
restartPath
focusWni :: WidgetNodeInfo
focusWni = WidgetNodeInfo -> Maybe WidgetNodeInfo -> WidgetNodeInfo
forall a. a -> Maybe a -> a
fromMaybe WidgetNodeInfo
forall a. Default a => a
def (WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
forall s e.
WidgetEnv s e -> WidgetNode s e -> Path -> Maybe WidgetNodeInfo
findWidgetByPath WidgetEnv s e
wenv WidgetNode s e
widgetRoot Path
start)
nextFocus :: Maybe WidgetNodeInfo
nextFocus = Maybe WidgetNodeInfo
candidateWni Maybe WidgetNodeInfo
-> Maybe WidgetNodeInfo -> Maybe WidgetNodeInfo
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe WidgetNodeInfo
fromRootWni Maybe WidgetNodeInfo
-> Maybe WidgetNodeInfo -> Maybe WidgetNodeInfo
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> WidgetNodeInfo -> Maybe WidgetNodeInfo
forall a. a -> Maybe a
Just WidgetNodeInfo
focusWni
dropNonParentWidgetId
:: MonomerM s e m
=> WidgetId
-> [(WidgetId, a)]
-> m [(WidgetId, a)]
dropNonParentWidgetId :: WidgetId -> [(WidgetId, a)] -> m [(WidgetId, a)]
dropNonParentWidgetId WidgetId
wid [] = [(WidgetId, a)] -> m [(WidgetId, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
dropNonParentWidgetId WidgetId
wid ((WidgetId, a)
x:[(WidgetId, a)]
xs) = do
Path
path <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
wid
Path
cpath <- WidgetId -> m Path
forall s e (m :: * -> *). MonomerM s e m => WidgetId -> m Path
getWidgetIdPath WidgetId
cwid
if Path -> Path -> Bool
forall a. Eq a => Seq a -> Seq a -> Bool
isParentPath Path
cpath Path
path
then [(WidgetId, a)] -> m [(WidgetId, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((WidgetId, a)
x(WidgetId, a) -> [(WidgetId, a)] -> [(WidgetId, a)]
forall a. a -> [a] -> [a]
:[(WidgetId, a)]
xs)
else WidgetId -> [(WidgetId, a)] -> m [(WidgetId, a)]
forall s e (m :: * -> *) a.
MonomerM s e m =>
WidgetId -> [(WidgetId, a)] -> m [(WidgetId, a)]
dropNonParentWidgetId WidgetId
wid [(WidgetId, a)]
xs
where
(WidgetId
cwid, a
_) = (WidgetId, a)
x
isParentPath :: Seq a -> Seq a -> Bool
isParentPath Seq a
parent Seq a
child = Seq a -> Seq a -> Bool
forall a. Eq a => Seq a -> Seq a -> Bool
seqStartsWith Seq a
parent Seq a
child Bool -> Bool -> Bool
&& Seq a
parent Seq a -> Seq a -> Bool
forall a. Eq a => a -> a -> Bool
/= Seq a
child
resetCursorOnNodeLeave
:: MonomerM s e m
=> SystemEvent
-> HandlerStep s e
-> m ()
resetCursorOnNodeLeave :: SystemEvent -> HandlerStep s e -> m ()
resetCursorOnNodeLeave (Leave Point
point) HandlerStep s e
step = do
m (HandlerStep s e) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (HandlerStep s e) -> m ()) -> m (HandlerStep s e) -> m ()
forall a b. (a -> b) -> a -> b
$ WidgetId -> HandlerStep s e -> m (HandlerStep s e)
forall s e (m :: * -> *).
MonomerM s e m =>
WidgetId -> HandlerStep s e -> m (HandlerStep s e)
handleResetCursorIcon WidgetId
widgetId HandlerStep s e
step
where
(WidgetEnv s e
wenv, WidgetNode s e
root, Seq (WidgetRequest s e)
_) = HandlerStep s e
step
widget :: Widget s e
widget = WidgetNode s e
root WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
childNode :: Maybe WidgetNodeInfo
childNode = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
root Path
emptyPath Point
point
widgetId :: WidgetId
widgetId = case Maybe WidgetNodeInfo
childNode of
Just WidgetNodeInfo
info -> WidgetNodeInfo
info WidgetNodeInfo
-> Getting WidgetId WidgetNodeInfo WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. Getting WidgetId WidgetNodeInfo WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
Maybe WidgetNodeInfo
Nothing -> WidgetNode s e
root WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> Getting WidgetId WidgetNodeInfo WidgetId
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting WidgetId WidgetNodeInfo WidgetId
forall s a. HasWidgetId s a => Lens' s a
L.widgetId
resetCursorOnNodeLeave SystemEvent
_ HandlerStep s e
step = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
restoreCursorOnWindowEnter :: MonomerM s e m => m ()
restoreCursorOnWindowEnter :: m ()
restoreCursorOnWindowEnter = do
Size Double
ww Double
wh <- Getting Size (MonomerCtx s e) Size -> m Size
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Size (MonomerCtx s e) Size
forall s a. HasWindowSize s a => Lens' s a
L.windowSize
InputStatus
status <- Getting InputStatus (MonomerCtx s e) InputStatus -> m InputStatus
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting InputStatus (MonomerCtx s e) InputStatus
forall s a. HasInputStatus s a => Lens' s a
L.inputStatus
Map CursorIcon Cursor
cursorIcons <- Getting
(Map CursorIcon Cursor) (MonomerCtx s e) (Map CursorIcon Cursor)
-> m (Map CursorIcon Cursor)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
(Map CursorIcon Cursor) (MonomerCtx s e) (Map CursorIcon Cursor)
forall s a. HasCursorIcons s a => Lens' s a
L.cursorIcons
Maybe (WidgetId, CursorIcon)
cursorPair <- [(WidgetId, CursorIcon)] -> Maybe (WidgetId, CursorIcon)
forall a. [a] -> Maybe a
headMay ([(WidgetId, CursorIcon)] -> Maybe (WidgetId, CursorIcon))
-> m [(WidgetId, CursorIcon)] -> m (Maybe (WidgetId, CursorIcon))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
let windowRect :: Rect
windowRect = Double -> Double -> Double -> Double -> Rect
Rect Double
0 Double
0 Double
ww Double
wh
let prevInside :: Bool
prevInside = Point -> Rect -> Bool
pointInRect (InputStatus
status InputStatus
-> ((Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus)
-> Point
forall s a. s -> Getting a s a -> a
^. (Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus
forall s a. HasMousePosPrev s a => Lens' s a
L.mousePosPrev) Rect
windowRect
let currInside :: Bool
currInside = Point -> Rect -> Bool
pointInRect (InputStatus
status InputStatus
-> ((Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus)
-> Point
forall s a. s -> Getting a s a -> a
^. (Point -> Const Point Point)
-> InputStatus -> Const Point InputStatus
forall s a. HasMousePos s a => Lens' s a
L.mousePos) Rect
windowRect
let sdlCursor :: Maybe Cursor
sdlCursor = Maybe (WidgetId, CursorIcon)
cursorPair Maybe (WidgetId, CursorIcon)
-> ((WidgetId, CursorIcon) -> Maybe Cursor) -> Maybe Cursor
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CursorIcon -> Map CursorIcon Cursor -> Maybe Cursor
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CursorIcon Cursor
cursorIcons) (CursorIcon -> Maybe Cursor)
-> ((WidgetId, CursorIcon) -> CursorIcon)
-> (WidgetId, CursorIcon)
-> Maybe Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId, CursorIcon) -> CursorIcon
forall a b. (a, b) -> b
snd
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Cursor -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Cursor
sdlCursor Bool -> Bool -> Bool
&& Maybe (WidgetId, CursorIcon) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (WidgetId, CursorIcon)
cursorPair) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid restoreCursorOnWindowEnter: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (WidgetId, CursorIcon) -> String
forall a. Show a => a -> String
show Maybe (WidgetId, CursorIcon)
cursorPair
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
prevInside Bool -> Bool -> Bool
&& Bool
currInside Bool -> Bool -> Bool
&& Maybe Cursor -> Bool
forall a. Maybe a -> Bool
isJust Maybe Cursor
sdlCursor) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Cursor -> m ()
forall (m :: * -> *). MonadIO m => Cursor -> m ()
SDLE.setCursor (Maybe Cursor -> Cursor
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Cursor
sdlCursor)
getTargetPath
:: WidgetEnv s e
-> WidgetNode s e
-> Maybe Path
-> Maybe Path
-> Path
-> SystemEvent
-> Maybe Path
getTargetPath :: WidgetEnv s e
-> WidgetNode s e
-> Maybe Path
-> Maybe Path
-> Path
-> SystemEvent
-> Maybe Path
getTargetPath WidgetEnv s e
wenv WidgetNode s e
root Maybe Path
pressed Maybe Path
overlay Path
target SystemEvent
event = case SystemEvent
event of
KeyAction{} -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
TextInput Text
_ -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
Clipboard ClipboardData
_ -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
ButtonAction Point
point Button
_ ButtonState
BtnPressed Int
_ -> Point -> Maybe Path
pointEvent Point
point
ButtonAction Point
_ Button
_ ButtonState
BtnReleased Int
_ -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
Click{} -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
WheelScroll Point
point Point
_ WheelDirection
_ -> Point -> Maybe Path
pointEvent Point
point
Focus{} -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
Blur{} -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
Enter{} -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
Move Point
point -> Point -> Maybe Path
pointEvent Point
point
Leave{} -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
Drag Point
point Path
_ WidgetDragMsg
_ -> Point -> Maybe Path
pointEvent Point
point
Drop Point
point Path
_ WidgetDragMsg
_ -> Point -> Maybe Path
pointEvent Point
point
where
widget :: Widget s e
widget = WidgetNode s e
root WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
L.widget
startPath :: Path
startPath = Path -> Maybe Path -> Path
forall a. a -> Maybe a -> a
fromMaybe Path
emptyPath Maybe Path
overlay
pathEvent :: a -> Maybe a
pathEvent = a -> Maybe a
forall a. a -> Maybe a
Just
pathFromPoint :: Point -> Maybe Path
pathFromPoint Point
p = (WidgetNodeInfo -> Path) -> Maybe WidgetNodeInfo -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WidgetNodeInfo -> Getting Path WidgetNodeInfo Path -> Path
forall s a. s -> Getting a s a -> a
^. Getting Path WidgetNodeInfo Path
forall s a. HasPath s a => Lens' s a
L.path) Maybe WidgetNodeInfo
wni where
wni :: Maybe WidgetNodeInfo
wni = Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
forall s e.
Widget s e
-> WidgetEnv s e
-> WidgetNode s e
-> Path
-> Point
-> Maybe WidgetNodeInfo
widgetFindByPoint Widget s e
widget WidgetEnv s e
wenv WidgetNode s e
root Path
startPath Point
p
pointEvent :: Point -> Maybe Path
pointEvent Point
point = Maybe Path
pressed Maybe Path -> Maybe Path -> Maybe Path
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Point -> Maybe Path
pathFromPoint Point
point Maybe Path -> Maybe Path -> Maybe Path
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Path
overlay
cursorToSDL :: CursorIcon -> SDLEnum.SystemCursor
cursorToSDL :: CursorIcon -> SystemCursor
cursorToSDL CursorIcon
CursorArrow = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_ARROW
cursorToSDL CursorIcon
CursorHand = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_HAND
cursorToSDL CursorIcon
CursorIBeam = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_IBEAM
cursorToSDL CursorIcon
CursorInvalid = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_NO
cursorToSDL CursorIcon
CursorSizeH = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_SIZEWE
cursorToSDL CursorIcon
CursorSizeV = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_SIZENS
cursorToSDL CursorIcon
CursorDiagTL = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_SIZENWSE
cursorToSDL CursorIcon
CursorDiagTR = SystemCursor
SDLEnum.SDL_SYSTEM_CURSOR_SIZENESW