{-|
Module      : Monomer.Main.Handlers
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Handlers for WidgetRequests. Functions in this module handle focus, clipboard,
overlays and all SystemEvent related operations and updates.
-}
{-# 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, seqStartsWith)
import Monomer.Main.Types
import Monomer.Main.Util

import qualified Monomer.Lens as L

{-|
Tuple representing the current widget environment, widget root and accumulated
WidgetRequests. These requests have already been processed, they are collected
for unit testing purposes.
-}
type HandlerStep s e = (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))

{-|
Processes a list of SystemEvents dispatching each of the to the corresponding
widget based on the current root. At each step the root may change, new events
may be generated (which will be processed interleaved with the list of events)
and this is handled before returning the latest "HandlerStep".
-}
handleSystemEvents
  :: MonomerM s e m
  => WidgetEnv s e       -- ^ The initial widget environment.
  -> WidgetNode s e      -- ^ The initial widget root.
  -> [SystemEvent]       -- ^ The starting list of events.
  -> m (HandlerStep s e) -- ^ The resulting "HandlerStep."
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
findChildNodeInfoByPath 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 findBranchByPath :: Path -> Seq WidgetNodeInfo
findBranchByPath Path
path = WidgetEnv s e -> WidgetNode s e -> Path -> Seq WidgetNodeInfo
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
          WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& ((Path -> Seq WidgetNodeInfo)
 -> Identity (Path -> Seq WidgetNodeInfo))
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasFindBranchByPath s a => Lens' s a
L.findBranchByPath (((Path -> Seq WidgetNodeInfo)
  -> Identity (Path -> Seq WidgetNodeInfo))
 -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (Path -> Seq WidgetNodeInfo) -> WidgetEnv s e -> WidgetEnv s e
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) <- 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

-- | Processes a single SystemEvent.
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

-- | Initializes system resources (currently only icons).
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

-- | Initializes a widget (in general, this is called for root).
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

-- | Disposes a widget (in general, this is called for root).
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

{-|
Handles a WidgetResult instance, processing events and requests, and returning
an updated "HandlerStep".
-}
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

-- | Processes a Seq of WidgetRequest, returning the latest "HandlerStep".
handleRequests
  :: MonomerM s e m
  => Seq (WidgetRequest s e)  -- ^ Requests to process.
  -> HandlerStep s e          -- ^ Initial state/"HandlerStep".
  -> m (HandlerStep s e)      -- ^ Updated "HandlerStep",
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 Millisecond
ms Maybe Int
repeat -> WidgetId
-> Millisecond
-> 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
-> Millisecond
-> Maybe Int
-> HandlerStep s e
-> m (HandlerStep s e)
handleRenderEvery WidgetId
wid Millisecond
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
    RunInRenderThread 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)
handleRunInRenderThread WidgetId
wid Path
path IO i
handler (WidgetEnv s e, WidgetNode s e, Seq (WidgetRequest s e))
step

-- | Resizes the current root, and marks the render and resized flags.
handleResizeWidgets
  :: MonomerM s e m
  => HandlerStep s e      -- ^ Current state/"HandlerStep".
  -> m (HandlerStep s e)  -- ^ Updated state/"HandlerStep".
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)
makeResizeCheckFn

  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
    makeResizeCheckFn :: m (Path -> Bool)
makeResizeCheckFn = 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
  -> Millisecond
  -> Maybe Int
  -> HandlerStep s e
  -> m (HandlerStep s e)
handleRenderEvery :: 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 <- 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
-> Millisecond -> Millisecond -> Maybe Int -> RenderSchedule
RenderSchedule {
      _rsWidgetId :: WidgetId
_rsWidgetId = WidgetId
widgetId,
      _rsStart :: Millisecond
_rsStart = WidgetEnv s e -> Millisecond
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 Millisecond -> Millisecond -> Bool
forall a. Ord a => a -> a -> Bool
> Millisecond
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
  Either Renderer (TChan (RenderMsg s e))
renderMethod <- Getting
  (Either Renderer (TChan (RenderMsg s e)))
  (MonomerCtx s e)
  (Either Renderer (TChan (RenderMsg s e)))
-> m (Either Renderer (TChan (RenderMsg s e)))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Either Renderer (TChan (RenderMsg s e)))
  (MonomerCtx s e)
  (Either Renderer (TChan (RenderMsg s e)))
forall s a. HasRenderMethod s a => Lens' s a
L.renderMethod

  case Either Renderer (TChan (RenderMsg s e))
renderMethod of
    Left Renderer
renderer -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Renderer -> Text -> IO ()
deleteImage Renderer
renderer Text
name
    Right TChan (RenderMsg s e)
chan -> 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)
chan (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
  --liftIO . putStrLn $ message ++ show (typeOf message)
  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

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 -> 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 <- Getting
  (Either Renderer (TChan (RenderMsg s e)))
  (MonomerCtx s e)
  (Either Renderer (TChan (RenderMsg s e)))
-> m (Either Renderer (TChan (RenderMsg s e)))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Either Renderer (TChan (RenderMsg s e)))
  (MonomerCtx s e)
  (Either Renderer (TChan (RenderMsg s e)))
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
      -- Force running in main thread to avoid issues with OpenGL
      i
result <- IO i -> m i
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO i
handler
      IO i -> m (IO i)
forall (m :: * -> *) a. Monad m => a -> m a
return (i -> IO i
forall (m :: * -> *) a. Monad m => a -> m a
return i
result)
    Right TChan (RenderMsg s e)
chan -> do
      IO i -> m (IO i)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO i -> m (IO i)) -> IO i -> m (IO i)
forall a b. (a -> b) -> a -> b
$ IO i -> IO i
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TChan (RenderMsg s e) -> IO i
forall s e. TChan (RenderMsg s e) -> IO i
taskWrapper TChan (RenderMsg s e)
chan)

  WidgetId -> Path -> IO i -> HandlerStep s e -> m (HandlerStep 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
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 <- IO (TChan i)
forall a. IO (TChan a)
newTChanIO
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
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 (TChan i -> IO i -> RenderMsg s e
forall s e i. TChan i -> IO i -> RenderMsg s e
MsgRunInRender TChan i
msgChan IO i
handler)
      STM i -> IO i
forall a. STM a -> IO a
atomically (STM i -> IO i) -> STM i -> IO i
forall a b. (a -> b) -> a -> b
$ TChan i -> STM i
forall a. TChan a -> STM a
readTChan TChan i
msgChan

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
    -- Update input status
    Point -> m ()
forall s e (m :: * -> *). MonomerM s e m => Point -> m ()
updateInputStatusMousePos Point
point
    -- Drag event
    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

    Point -> m ()
forall s e (m :: * -> *). MonomerM s e m => Point -> m ()
updateInputStatusMousePos Point
point
    (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
    -- Hover changes need to be handled here too
    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)
_ -> []

    Point -> m ()
forall s e (m :: * -> *). MonomerM s e m => Point -> m ()
updateInputStatusMousePos Point
point
    (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)]
  -- These handlers are only here to help with testing functions
  -- This will only be reached from `handleSystemEvents`
  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)]

updateInputStatusMousePos :: MonomerM s e m => Point -> m ()
updateInputStatusMousePos :: Point -> m ()
updateInputStatusMousePos Point
point = do
  -- Update input status
  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

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
findChildNodeInfoByPath 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
  -- Restore old icon if needed
  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
    -- Keyboard
    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
    Clipboard ClipboardData
_                       -> Path -> Maybe Path
forall a. a -> Maybe a
pathEvent Path
target
    -- Mouse/touch
    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/drop
    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
    -- pressed is only really used for Move
    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