{-|
Module      : KMonad.Model.Sluice
Description : The component that provides pausing functionality
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

For certain KMonad operations we need to be able to pause and resume processing
of events. This component provides the ability to temporarily pause processing,
and then resume processing and return all events that were caught while paused.

-}
module KMonad.Model.Sluice
  ( Sluice
  , mkSluice
  , block
  , unblock
  , pull
  )
where

import KMonad.Prelude

import KMonad.Keyboard

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

-- | The 'Sluice' environment.
--
-- NOTE: 'Sluice' has no internal multithreading, i.e. its 'pull' action will
-- never be interrupted, therefore we can simply use 'IORef' and sidestep all
-- the STM complications.
data Sluice = Sluice
  { Sluice -> IO KeyEvent
_eventSrc :: IO KeyEvent      -- ^ Where we get our 'KeyEvent's from
  , Sluice -> IORef Int
_blocked  :: IORef Int        -- ^ How many locks have been applied to the sluice
  , Sluice -> IORef [KeyEvent]
_blockBuf :: IORef [KeyEvent] -- ^ Internal buffer to store events while closed
  }
makeLenses ''Sluice

-- | Create a new 'Sluice' environment
mkSluice' :: MonadUnliftIO m => m KeyEvent -> m Sluice
mkSluice' :: forall (m :: * -> *). MonadUnliftIO m => m KeyEvent -> m Sluice
mkSluice' m KeyEvent
s = ((forall a. m a -> IO a) -> IO Sluice) -> m Sluice
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO Sluice) -> m Sluice)
-> ((forall a. m a -> IO a) -> IO Sluice) -> m Sluice
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
u -> do
  IORef Int
bld <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int
0
  IORef [KeyEvent]
buf <- [KeyEvent] -> IO (IORef [KeyEvent])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
  Sluice -> IO Sluice
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sluice -> IO Sluice) -> Sluice -> IO Sluice
forall a b. (a -> b) -> a -> b
$ IO KeyEvent -> IORef Int -> IORef [KeyEvent] -> Sluice
Sluice (m KeyEvent -> IO KeyEvent
forall a. m a -> IO a
u m KeyEvent
s) IORef Int
bld IORef [KeyEvent]
buf

-- | Create a new 'Sluice' environment, but do so in a ContT context
mkSluice :: MonadUnliftIO m => m KeyEvent -> ContT r m Sluice
mkSluice :: forall (m :: * -> *) r.
MonadUnliftIO m =>
m KeyEvent -> ContT r m Sluice
mkSluice = m Sluice -> ContT r m Sluice
forall (m :: * -> *) a. Monad m => m a -> ContT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Sluice -> ContT r m Sluice)
-> (m KeyEvent -> m Sluice) -> m KeyEvent -> ContT r m Sluice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m KeyEvent -> m Sluice
forall (m :: * -> *). MonadUnliftIO m => m KeyEvent -> m Sluice
mkSluice'


--------------------------------------------------------------------------------
-- $op
--
-- The following code deals with simple operations on the environment, like
-- blocking and unblocking the sluice.

-- | Increase the block-count by 1
block :: HasLogFunc e => Sluice -> RIO e ()
block :: forall e. HasLogFunc e => Sluice -> RIO e ()
block Sluice
s = do
  IORef Int -> (Int -> Int) -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef (Sluice
sSluice -> Getting (IORef Int) Sluice (IORef Int) -> IORef Int
forall s a. s -> Getting a s a -> a
^.Getting (IORef Int) Sluice (IORef Int)
Lens' Sluice (IORef Int)
blocked) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  IORef Int -> RIO e Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Sluice
sSluice -> Getting (IORef Int) Sluice (IORef Int) -> IORef Int
forall s a. s -> Getting a s a -> a
^.Getting (IORef Int) Sluice (IORef Int)
Lens' Sluice (IORef Int)
blocked) RIO e Int -> (Int -> RIO e ()) -> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n ->
    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
$ Utf8Builder
"Block level set to: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
n

-- | Set the Sluice to unblocked mode, return a list of all the stored events
-- that should be rerun, in the correct order (head was first-in, etc).
--
-- NOTE: After successfully unblocking the 'Sluice' will be empty, it is the
-- caller's responsibility to insert the returned events at an appropriate
-- location in the 'KMonad.App.App'.
--
-- We do this in KMonad by writing the events into the
-- 'KMonad.Model.Dispatch.Dispatch's rerun buffer. (this happens in the
-- "KMonad.App" module.)
unblock :: HasLogFunc e => Sluice -> RIO e [KeyEvent]
unblock :: forall e. HasLogFunc e => Sluice -> RIO e [KeyEvent]
unblock Sluice
s = do
  IORef Int -> (Int -> Int) -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' (Sluice
sSluice -> Getting (IORef Int) Sluice (IORef Int) -> IORef Int
forall s a. s -> Getting a s a -> a
^.Getting (IORef Int) Sluice (IORef Int)
Lens' Sluice (IORef Int)
blocked) (\Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  IORef Int -> RIO e Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Sluice
sSluice -> Getting (IORef Int) Sluice (IORef Int) -> IORef Int
forall s a. s -> Getting a s a -> a
^.Getting (IORef Int) Sluice (IORef Int)
Lens' Sluice (IORef Int)
blocked) RIO e Int -> (Int -> RIO e [KeyEvent]) -> RIO e [KeyEvent]
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Int
0 -> do
      [KeyEvent]
es <- IORef [KeyEvent] -> RIO e [KeyEvent]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Sluice
sSluice
-> Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
-> IORef [KeyEvent]
forall s a. s -> Getting a s a -> a
^.Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
Lens' Sluice (IORef [KeyEvent])
blockBuf)
      IORef [KeyEvent] -> [KeyEvent] -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (Sluice
sSluice
-> Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
-> IORef [KeyEvent]
forall s a. s -> Getting a s a -> a
^.Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
Lens' Sluice (IORef [KeyEvent])
blockBuf) []
      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
$ Utf8Builder
"Unblocking input stream, " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        if [KeyEvent] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeyEvent]
es
        then Utf8Builder
"no stored events"
        else Utf8Builder
"rerunning:\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder)
-> ([KeyEvent] -> Text) -> [KeyEvent] -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unlines ([Text] -> Text) -> ([KeyEvent] -> [Text]) -> [KeyEvent] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyEvent -> Text) -> [KeyEvent] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map KeyEvent -> Text
forall a. Display a => a -> Text
textDisplay ([KeyEvent] -> Utf8Builder) -> [KeyEvent] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ [KeyEvent] -> [KeyEvent]
forall a. [a] -> [a]
reverse [KeyEvent]
es)
      [KeyEvent] -> RIO e [KeyEvent]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([KeyEvent] -> RIO e [KeyEvent]) -> [KeyEvent] -> RIO e [KeyEvent]
forall a b. (a -> b) -> a -> b
$ [KeyEvent] -> [KeyEvent]
forall a. [a] -> [a]
reverse [KeyEvent]
es
    Int
n -> 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
$ Utf8Builder
"Block level set to: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
n
      [KeyEvent] -> RIO e [KeyEvent]
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []


--------------------------------------------------------------------------------
-- $loop
--
-- The following code deals with how a 'Sluice' fits into the KMonad pull-chain.
-- As long as we are blocked, we do not return any events, but keep storing them
-- internally. When we are unblocked, events simply pass through.


-- | Try to read from the Sluice, if we are blocked, store the event internally
-- and return Nothing. If we are unblocked, return Just the KeyEvent.
step :: HasLogFunc e => Sluice -> RIO e (Maybe KeyEvent)
step :: forall e. HasLogFunc e => Sluice -> RIO e (Maybe KeyEvent)
step Sluice
s = do
  KeyEvent
e <- IO KeyEvent -> RIO e KeyEvent
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO KeyEvent -> RIO e KeyEvent) -> IO KeyEvent -> RIO e KeyEvent
forall a b. (a -> b) -> a -> b
$ Sluice
sSluice -> Getting (IO KeyEvent) Sluice (IO KeyEvent) -> IO KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting (IO KeyEvent) Sluice (IO KeyEvent)
Lens' Sluice (IO KeyEvent)
eventSrc
  IORef Int -> RIO e Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Sluice
sSluice -> Getting (IORef Int) Sluice (IORef Int) -> IORef Int
forall s a. s -> Getting a s a -> a
^.Getting (IORef Int) Sluice (IORef Int)
Lens' Sluice (IORef Int)
blocked) RIO e Int
-> (Int -> RIO e (Maybe KeyEvent)) -> RIO e (Maybe KeyEvent)
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Int
0 -> Maybe KeyEvent -> RIO e (Maybe KeyEvent)
forall a. a -> RIO e a
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
    Int
_ -> do
      IORef [KeyEvent] -> ([KeyEvent] -> [KeyEvent]) -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' (Sluice
sSluice
-> Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
-> IORef [KeyEvent]
forall s a. s -> Getting a s a -> a
^.Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
Lens' Sluice (IORef [KeyEvent])
blockBuf) (KeyEvent
eKeyEvent -> [KeyEvent] -> [KeyEvent]
forall a. a -> [a] -> [a]
:)
      IORef [KeyEvent] -> RIO e [KeyEvent]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Sluice
sSluice
-> Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
-> IORef [KeyEvent]
forall s a. s -> Getting a s a -> a
^.Getting (IORef [KeyEvent]) Sluice (IORef [KeyEvent])
Lens' Sluice (IORef [KeyEvent])
blockBuf) RIO e [KeyEvent] -> ([KeyEvent] -> RIO e ()) -> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[KeyEvent]
es -> do
        let xs :: [Text]
xs = (KeyEvent -> Text) -> [KeyEvent] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
" - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (KeyEvent -> Text) -> KeyEvent -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyEvent -> Text
forall a. Display a => a -> Text
textDisplay) [KeyEvent]
es
        Utf8Builder -> RIO e ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO e ())
-> ([Text] -> Utf8Builder) -> [Text] -> RIO e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> ([Text] -> Text) -> [Text] -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unlines ([Text] -> RIO e ()) -> [Text] -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Text
"Storing event, current store: "Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs
      Maybe KeyEvent -> RIO e (Maybe KeyEvent)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe KeyEvent
forall a. Maybe a
Nothing

-- | Keep trying to read from the Sluice until an event passes through
pull :: HasLogFunc e => Sluice -> RIO e KeyEvent
pull :: forall e. HasLogFunc e => Sluice -> RIO e KeyEvent
pull Sluice
s = Sluice -> RIO e (Maybe KeyEvent)
forall e. HasLogFunc e => Sluice -> RIO e (Maybe KeyEvent)
step Sluice
s RIO e (Maybe KeyEvent)
-> (Maybe KeyEvent -> RIO e KeyEvent) -> RIO e KeyEvent
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
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 (Sluice -> RIO e KeyEvent
forall e. HasLogFunc e => Sluice -> RIO e KeyEvent
pull Sluice
s) KeyEvent -> RIO e KeyEvent
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure