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