{-|
Module      : KMonad.App.Hooks
Description : Component for handling hooks
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

Part of the KMonad deferred-decision mechanics are implemented using hooks,
which will call predicates and actions on future keypresses and/or timer events.
The 'Hooks' component is the concrete implementation of this functionality.

In the sequencing of components, this happens second, right after the
'KMonad.App.Dispatch.Dispatch' component.

-}
module KMonad.App.Hooks
  ( Hooks
  , mkHooks
  , pull
  , register
  )
where

import KMonad.Prelude

import Data.Time.Clock.System
import Data.Unique

import KMonad.Action hiding (register)
import KMonad.Keyboard
import KMonad.Util

import RIO.Partial (fromJust)

import qualified RIO.HashMap as M

--------------------------------------------------------------------------------
-- $hooks



-- -- | A 'Hook' contains the 'KeyPred' and 'Callback'
-- newtype Hook = Hook (KeyPred, Callback IO)
-- makeWrapped ''Hook

-- -- | Create a new 'Hook' value
-- mkHook :: MonadUnliftIO m => KeyPred -> Callback m -> m Hook
-- mkHook p c = withRunInIO $ \u -> pure $ Hook (p, (u . c))

--------------------------------------------------------------------------------
-- $env

data Entry = Entry
  { Entry -> SystemTime
_time  :: SystemTime
  , Entry -> Hook IO
_eHook :: Hook IO
  }
makeLenses ''Entry

instance HasHook Entry IO where hook :: (Hook IO -> f (Hook IO)) -> Entry -> f Entry
hook = (Hook IO -> f (Hook IO)) -> Entry -> f Entry
Lens' Entry (Hook IO)
eHook

type Store = M.HashMap Unique Entry

-- | The 'Hooks' environment that is required for keeping track of all the
-- different targets and callbacks.
data Hooks = Hooks
  { Hooks -> IO KeyEvent
_eventSrc   :: IO KeyEvent   -- ^ Where we get our events from
  , Hooks -> TMVar Unique
_injectTmr  :: TMVar Unique  -- ^ Used to signal timeouts
  , Hooks -> TVar Store
_hooks      :: TVar Store    -- ^ Store of hooks
  }
makeLenses ''Hooks

-- | Create a new 'Hooks' environment which reads events from the provided action
mkHooks' :: MonadUnliftIO m => m KeyEvent -> m Hooks
mkHooks' :: m KeyEvent -> m Hooks
mkHooks' s :: m KeyEvent
s = ((forall a. m a -> IO a) -> IO Hooks) -> m Hooks
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Hooks) -> m Hooks)
-> ((forall a. m a -> IO a) -> IO Hooks) -> m Hooks
forall a b. (a -> b) -> a -> b
$ \u :: forall a. m a -> IO a
u -> do
  TMVar Unique
itr <- STM (TMVar Unique) -> IO (TMVar Unique)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TMVar Unique) -> IO (TMVar Unique))
-> STM (TMVar Unique) -> IO (TMVar Unique)
forall a b. (a -> b) -> a -> b
$ STM (TMVar Unique)
forall a. STM (TMVar a)
newEmptyTMVar
  TVar Store
hks <- STM (TVar Store) -> IO (TVar Store)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TVar Store) -> IO (TVar Store))
-> STM (TVar Store) -> IO (TVar Store)
forall a b. (a -> b) -> a -> b
$ Store -> STM (TVar Store)
forall a. a -> STM (TVar a)
newTVar Store
forall k v. HashMap k v
M.empty
  Hooks -> IO Hooks
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hooks -> IO Hooks) -> Hooks -> IO Hooks
forall a b. (a -> b) -> a -> b
$ IO KeyEvent -> TMVar Unique -> TVar Store -> Hooks
Hooks (m KeyEvent -> IO KeyEvent
forall a. m a -> IO a
u m KeyEvent
s) TMVar Unique
itr TVar Store
hks

-- | Create a new 'Hooks' environment, but as a 'ContT' monad to avoid nesting
mkHooks :: MonadUnliftIO m => m KeyEvent -> ContT r m Hooks
mkHooks :: m KeyEvent -> ContT r m Hooks
mkHooks = m Hooks -> ContT r m Hooks
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Hooks -> ContT r m Hooks)
-> (m KeyEvent -> m Hooks) -> m KeyEvent -> ContT r m Hooks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m KeyEvent -> m Hooks
forall (m :: * -> *). MonadUnliftIO m => m KeyEvent -> m Hooks
mkHooks'

-- | Convert a hook in some UnliftIO monad into an IO version, to store it in Hooks
ioHook :: MonadUnliftIO m => Hook m -> m (Hook IO)
ioHook :: Hook m -> m (Hook IO)
ioHook h :: Hook m
h = ((forall a. m a -> IO a) -> IO (Hook IO)) -> m (Hook IO)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Hook IO)) -> m (Hook IO))
-> ((forall a. m a -> IO a) -> IO (Hook IO)) -> m (Hook IO)
forall a b. (a -> b) -> a -> b
$ \u :: forall a. m a -> IO a
u -> do

  Maybe (Timeout IO)
t <- case Hook m -> Maybe (Timeout m)
forall (m :: * -> *). Hook m -> Maybe (Timeout m)
_hTimeout Hook m
h of
    Nothing -> Maybe (Timeout IO) -> IO (Maybe (Timeout IO))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Timeout IO)
forall a. Maybe a
Nothing
    Just t' :: Timeout m
t' -> Maybe (Timeout IO) -> IO (Maybe (Timeout IO))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Timeout IO) -> IO (Maybe (Timeout IO)))
-> (Timeout IO -> Maybe (Timeout IO))
-> Timeout IO
-> IO (Maybe (Timeout IO))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timeout IO -> Maybe (Timeout IO)
forall a. a -> Maybe a
Just (Timeout IO -> IO (Maybe (Timeout IO)))
-> Timeout IO -> IO (Maybe (Timeout IO))
forall a b. (a -> b) -> a -> b
$ Milliseconds -> IO () -> Timeout IO
forall (m :: * -> *). Milliseconds -> m () -> Timeout m
Timeout (Timeout m
t'Timeout m
-> Getting Milliseconds (Timeout m) Milliseconds -> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds (Timeout m) Milliseconds
forall c (m :: * -> *). HasTimeout c m => Lens' c Milliseconds
delay) (m () -> IO ()
forall a. m a -> IO a
u (Timeout m -> m ()
forall (m :: * -> *). Timeout m -> m ()
_action Timeout m
t'))
  let f :: Trigger -> IO Catch
f = \e :: Trigger
e -> m Catch -> IO Catch
forall a. m a -> IO a
u (m Catch -> IO Catch) -> m Catch -> IO Catch
forall a b. (a -> b) -> a -> b
$ (Hook m -> Trigger -> m Catch
forall (m :: * -> *). Hook m -> Trigger -> m Catch
_keyH Hook m
h) Trigger
e
  Hook IO -> IO (Hook IO)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hook IO -> IO (Hook IO)) -> Hook IO -> IO (Hook IO)
forall a b. (a -> b) -> a -> b
$ Maybe (Timeout IO) -> (Trigger -> IO Catch) -> Hook IO
forall (m :: * -> *).
Maybe (Timeout m) -> (Trigger -> m Catch) -> Hook m
Hook Maybe (Timeout IO)
t Trigger -> IO Catch
f


--------------------------------------------------------------------------------
-- $op
--
-- The following code deals with simple operations on the environment, like
-- inserting and removing hooks.

-- | Insert a hook, along with the current time, into the store
register :: (HasLogFunc e)
  => Hooks
  -> Hook (RIO e)
  -> RIO e ()
register :: Hooks -> Hook (RIO e) -> RIO e ()
register hs :: Hooks
hs h :: Hook (RIO e)
h = do
  -- Insert an entry into the store
  Unique
tag <- IO Unique -> RIO e Unique
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
newUnique
  Entry
e   <- SystemTime -> Hook IO -> Entry
Entry (SystemTime -> Hook IO -> Entry)
-> RIO e SystemTime -> RIO e (Hook IO -> Entry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime -> RIO e SystemTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime RIO e (Hook IO -> Entry) -> RIO e (Hook IO) -> RIO e Entry
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Hook (RIO e) -> RIO e (Hook IO)
forall (m :: * -> *). MonadUnliftIO m => Hook m -> m (Hook IO)
ioHook Hook (RIO e)
h
  STM () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO e ()) -> STM () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ TVar Store -> (Store -> Store) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Hooks
hsHooks -> Getting (TVar Store) Hooks (TVar Store) -> TVar Store
forall s a. s -> Getting a s a -> a
^.Getting (TVar Store) Hooks (TVar Store)
Lens' Hooks (TVar Store)
hooks) (Unique -> Entry -> Store -> Store
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Unique
tag Entry
e)
  -- If the hook has a timeout, start a thread that will signal timeout
  case Hook (RIO e)
hHook (RIO e)
-> Getting
     (Maybe (Timeout (RIO e))) (Hook (RIO e)) (Maybe (Timeout (RIO e)))
-> Maybe (Timeout (RIO e))
forall s a. s -> Getting a s a -> a
^.Getting
  (Maybe (Timeout (RIO e))) (Hook (RIO e)) (Maybe (Timeout (RIO e)))
forall c (m :: * -> *). HasHook c m => Lens' c (Maybe (Timeout m))
hTimeout of
    Nothing -> Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Registering untimed hook: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Unique -> Int
hashUnique Unique
tag)
    Just t' :: Timeout (RIO e)
t' -> RIO e (Async ()) -> RIO e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO e (Async ()) -> RIO e ())
-> (RIO e () -> RIO e (Async ())) -> RIO e () -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RIO e () -> RIO e (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (RIO e () -> RIO e ()) -> RIO e () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ do
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Registering " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Milliseconds -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Timeout (RIO e)
t'Timeout (RIO e)
-> Getting Milliseconds (Timeout (RIO e)) Milliseconds
-> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds (Timeout (RIO e)) Milliseconds
forall c (m :: * -> *). HasTimeout c m => Lens' c Milliseconds
delay)
              Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "ms hook: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Unique -> Int
hashUnique Unique
tag)
      Int -> RIO e ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> RIO e ()) -> Int -> RIO e ()
forall a b. (a -> b) -> a -> b
$ 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Milliseconds -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Milliseconds -> Int) -> Milliseconds -> Int
forall a b. (a -> b) -> a -> b
$ Timeout (RIO e)
t'Timeout (RIO e)
-> Getting Milliseconds (Timeout (RIO e)) Milliseconds
-> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds (Timeout (RIO e)) Milliseconds
forall c (m :: * -> *). HasTimeout c m => Lens' c Milliseconds
delay)
      STM () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO e ()) -> STM () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ TMVar Unique -> Unique -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (Hooks
hsHooks
-> Getting (TMVar Unique) Hooks (TMVar Unique) -> TMVar Unique
forall s a. s -> Getting a s a -> a
^.Getting (TMVar Unique) Hooks (TMVar Unique)
Lens' Hooks (TMVar Unique)
injectTmr) Unique
tag

-- | Cancel a hook by removing it from the store
cancelHook :: (HasLogFunc e)
  => Hooks
  -> Unique
  -> RIO e ()
cancelHook :: Hooks -> Unique -> RIO e ()
cancelHook hs :: Hooks
hs tag :: Unique
tag = do
  Maybe Entry
e <- STM (Maybe Entry) -> RIO e (Maybe Entry)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe Entry) -> RIO e (Maybe Entry))
-> STM (Maybe Entry) -> RIO e (Maybe Entry)
forall a b. (a -> b) -> a -> b
$ do
    Store
m <- TVar Store -> STM Store
forall a. TVar a -> STM a
readTVar (TVar Store -> STM Store) -> TVar Store -> STM Store
forall a b. (a -> b) -> a -> b
$ Hooks
hsHooks -> Getting (TVar Store) Hooks (TVar Store) -> TVar Store
forall s a. s -> Getting a s a -> a
^.Getting (TVar Store) Hooks (TVar Store)
Lens' Hooks (TVar Store)
hooks
    let v :: Maybe Entry
v = Unique -> Store -> Maybe Entry
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Unique
tag Store
m
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Entry -> Bool
forall a. Maybe a -> Bool
isJust Maybe Entry
v) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar Store -> (Store -> Store) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (Hooks
hsHooks -> Getting (TVar Store) Hooks (TVar Store) -> TVar Store
forall s a. s -> Getting a s a -> a
^.Getting (TVar Store) Hooks (TVar Store)
Lens' Hooks (TVar Store)
hooks) (Unique -> Store -> Store
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete Unique
tag)
    Maybe Entry -> STM (Maybe Entry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Entry
v
  case Maybe Entry
e of
    Nothing ->
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Tried cancelling expired hook: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Unique -> Int
hashUnique Unique
tag)
    Just e' :: Entry
e' -> do
      Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Cancelling hook: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Unique -> Int
hashUnique Unique
tag)
      IO () -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Entry
e' Entry -> Getting (IO ()) Entry (IO ()) -> IO ()
forall s a. s -> Getting a s a -> a
^. (Maybe (Timeout IO) -> Const (IO ()) (Maybe (Timeout IO)))
-> Entry -> Const (IO ()) Entry
forall c (m :: * -> *). HasHook c m => Lens' c (Maybe (Timeout m))
hTimeout ((Maybe (Timeout IO) -> Const (IO ()) (Maybe (Timeout IO)))
 -> Entry -> Const (IO ()) Entry)
-> ((IO () -> Const (IO ()) (IO ()))
    -> Maybe (Timeout IO) -> Const (IO ()) (Maybe (Timeout IO)))
-> Getting (IO ()) Entry (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Timeout IO) -> Timeout IO)
-> Optic' (->) (Const (IO ())) (Maybe (Timeout IO)) (Timeout IO)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Maybe (Timeout IO) -> Timeout IO
forall a. HasCallStack => Maybe a -> a
fromJust Optic' (->) (Const (IO ())) (Maybe (Timeout IO)) (Timeout IO)
-> ((IO () -> Const (IO ()) (IO ()))
    -> Timeout IO -> Const (IO ()) (Timeout IO))
-> (IO () -> Const (IO ()) (IO ()))
-> Maybe (Timeout IO)
-> Const (IO ()) (Maybe (Timeout IO))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO () -> Const (IO ()) (IO ()))
-> Timeout IO -> Const (IO ()) (Timeout IO)
forall c (m :: * -> *). HasTimeout c m => Lens' c (m ())
action


--------------------------------------------------------------------------------
-- $run
--
-- The following code deals with how we check hooks against incoming events, and
-- how this updates the 'Hooks' environment.

-- | Run the function stored in a Hook on the event and the elapsed time
runEntry :: MonadIO m => SystemTime -> KeyEvent -> Entry -> m Catch
runEntry :: SystemTime -> KeyEvent -> Entry -> m Catch
runEntry t :: SystemTime
t e :: KeyEvent
e v :: Entry
v = IO Catch -> m Catch
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Catch -> m Catch) -> IO Catch -> m Catch
forall a b. (a -> b) -> a -> b
$ do
  (Entry
vEntry
-> Getting (Trigger -> IO Catch) Entry (Trigger -> IO Catch)
-> Trigger
-> IO Catch
forall s a. s -> Getting a s a -> a
^.Getting (Trigger -> IO Catch) Entry (Trigger -> IO Catch)
forall c (m :: * -> *). HasHook c m => Lens' c (Trigger -> m Catch)
keyH) (Trigger -> IO Catch) -> Trigger -> IO Catch
forall a b. (a -> b) -> a -> b
$ Milliseconds -> KeyEvent -> Trigger
Trigger ((Entry
vEntry -> Getting SystemTime Entry SystemTime -> SystemTime
forall s a. s -> Getting a s a -> a
^.Getting SystemTime Entry SystemTime
Lens' Entry SystemTime
time) SystemTime -> SystemTime -> Milliseconds
`tDiff` SystemTime
t) KeyEvent
e

-- | Run all hooks on the current event and reset the store
runHooks :: (HasLogFunc e)
  => Hooks
  -> KeyEvent
  -> RIO e (Maybe KeyEvent)
runHooks :: Hooks -> KeyEvent -> RIO e (Maybe KeyEvent)
runHooks hs :: Hooks
hs e :: KeyEvent
e = do
  Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug "Running hooks"
  Store
m   <- STM Store -> RIO e Store
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Store -> RIO e Store) -> STM Store -> RIO e Store
forall a b. (a -> b) -> a -> b
$ TVar Store -> Store -> STM Store
forall a. TVar a -> a -> STM a
swapTVar (Hooks
hsHooks -> Getting (TVar Store) Hooks (TVar Store) -> TVar Store
forall s a. s -> Getting a s a -> a
^.Getting (TVar Store) Hooks (TVar Store)
Lens' Hooks (TVar Store)
hooks) Store
forall k v. HashMap k v
M.empty
  SystemTime
now <- IO SystemTime -> RIO e SystemTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SystemTime
getSystemTime
  (Entry -> RIO e Catch) -> [Entry] -> RIO e Catch
forall (m :: * -> *) w (t :: * -> *) a.
(Monad m, Monoid w, Foldable t) =>
(a -> m w) -> t a -> m w
foldMapM (SystemTime -> KeyEvent -> Entry -> RIO e Catch
forall (m :: * -> *).
MonadIO m =>
SystemTime -> KeyEvent -> Entry -> m Catch
runEntry SystemTime
now KeyEvent
e) (Store -> [Entry]
forall k v. HashMap k v -> [v]
M.elems Store
m) RIO e Catch
-> (Catch -> RIO e (Maybe KeyEvent)) -> RIO e (Maybe KeyEvent)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Catch   -> Maybe KeyEvent -> RIO e (Maybe KeyEvent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KeyEvent -> RIO e (Maybe KeyEvent))
-> Maybe KeyEvent -> RIO e (Maybe KeyEvent)
forall a b. (a -> b) -> a -> b
$ Maybe KeyEvent
forall a. Maybe a
Nothing
    NoCatch -> Maybe KeyEvent -> RIO e (Maybe KeyEvent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe KeyEvent -> RIO e (Maybe KeyEvent))
-> Maybe KeyEvent -> RIO e (Maybe KeyEvent)
forall a b. (a -> b) -> a -> b
$ KeyEvent -> Maybe KeyEvent
forall a. a -> Maybe a
Just KeyEvent
e


--------------------------------------------------------------------------------
-- $loop
--
-- The following code deals with how to use the 'Hooks' component as part of a
-- pull-chain. It contains logic for how to try to pull events from upstream and
-- check them against the hooks, and for how to keep stepping until an unhandled
-- event comes through.

-- | Pull 1 event from the '_eventSrc'. If that action is not caught by any
-- callback, then return it (otherwise return Nothing). At the same time, keep
-- reading the timer-cancellation inject point and handle any cancellation as it
-- comes up.
step :: (HasLogFunc e)
  => Hooks                  -- ^ The 'Hooks' environment
  -> RIO e (Maybe KeyEvent) -- ^ An action that returns perhaps the next event
step :: Hooks -> RIO e (Maybe KeyEvent)
step h :: Hooks
h = do

  -- Asynchronously start reading the next event
  Async KeyEvent
a <- RIO e KeyEvent -> RIO e (Async KeyEvent)
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (RIO e KeyEvent -> RIO e (Async KeyEvent))
-> (IO KeyEvent -> RIO e KeyEvent)
-> IO KeyEvent
-> RIO e (Async KeyEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO KeyEvent -> RIO e KeyEvent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KeyEvent -> RIO e (Async KeyEvent))
-> IO KeyEvent -> RIO e (Async KeyEvent)
forall a b. (a -> b) -> a -> b
$ Hooks
hHooks -> Getting (IO KeyEvent) Hooks (IO KeyEvent) -> IO KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting (IO KeyEvent) Hooks (IO KeyEvent)
Lens' Hooks (IO KeyEvent)
eventSrc
 
  -- Handle any timer event first, and then try to read from the source
  let next :: STM (Either Unique KeyEvent)
next = (Unique -> Either Unique KeyEvent
forall a b. a -> Either a b
Left (Unique -> Either Unique KeyEvent)
-> STM Unique -> STM (Either Unique KeyEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar Unique -> STM Unique
forall a. TMVar a -> STM a
takeTMVar (Hooks
hHooks
-> Getting (TMVar Unique) Hooks (TMVar Unique) -> TMVar Unique
forall s a. s -> Getting a s a -> a
^.Getting (TMVar Unique) Hooks (TMVar Unique)
Lens' Hooks (TMVar Unique)
injectTmr)) STM (Either Unique KeyEvent)
-> STM (Either Unique KeyEvent) -> STM (Either Unique KeyEvent)
forall a. STM a -> STM a -> STM a
`orElse` (KeyEvent -> Either Unique KeyEvent
forall a b. b -> Either a b
Right (KeyEvent -> Either Unique KeyEvent)
-> STM KeyEvent -> STM (Either Unique KeyEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async KeyEvent -> STM KeyEvent
forall a. Async a -> STM a
waitSTM Async KeyEvent
a)

  -- Keep taking and cancelling timers until we encounter a key event, then run
  -- the hooks on that event.
  let read :: RIO e (Maybe KeyEvent)
read = STM (Either Unique KeyEvent) -> RIO e (Either Unique KeyEvent)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM (Either Unique KeyEvent)
next RIO e (Either Unique KeyEvent)
-> (Either Unique KeyEvent -> RIO e (Maybe KeyEvent))
-> RIO e (Maybe KeyEvent)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left  t :: Unique
t -> Hooks -> Unique -> RIO e ()
forall e. HasLogFunc e => Hooks -> Unique -> RIO e ()
cancelHook Hooks
h Unique
t RIO e () -> RIO e (Maybe KeyEvent) -> RIO e (Maybe KeyEvent)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RIO e (Maybe KeyEvent)
read -- We caught a cancellation
        Right e :: KeyEvent
e -> Hooks -> KeyEvent -> RIO e (Maybe KeyEvent)
forall e.
HasLogFunc e =>
Hooks -> KeyEvent -> RIO e (Maybe KeyEvent)
runHooks Hooks
h KeyEvent
e           -- We caught a real event
  RIO e (Maybe KeyEvent)
read

-- | Keep stepping until we succesfully get an unhandled 'KeyEvent'
pull :: HasLogFunc e
  => Hooks
  -> RIO e KeyEvent
pull :: Hooks -> RIO e KeyEvent
pull h :: Hooks
h = Hooks -> RIO e (Maybe KeyEvent)
forall e. HasLogFunc e => Hooks -> RIO e (Maybe KeyEvent)
step Hooks
h RIO e (Maybe KeyEvent)
-> (Maybe KeyEvent -> RIO e KeyEvent) -> RIO e KeyEvent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RIO e KeyEvent
-> (KeyEvent -> RIO e KeyEvent) -> Maybe KeyEvent -> RIO e KeyEvent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Hooks -> RIO e KeyEvent
forall e. HasLogFunc e => Hooks -> RIO e KeyEvent
pull Hooks
h) KeyEvent -> RIO e KeyEvent
forall (f :: * -> *) a. Applicative f => a -> f a
pure