{-|
Module      : KMonad.Action
Description : Collection of basic operations
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

KMonad is implemented as an engine that is capable of running 'MonadK' actions.
The logic of various different buttons and keyboard operations are expressed in
this 'MonadK'. This module defines the basic types and operations that make up
'MonadK'. The implementation of how KMonad implements 'MonadK' can be found in
the "KMonad.App" module.

NOTE: All of this is a bit muddled, and redoing the way hooks are handled, and
the basic structuring of MonadK and MonadKIO are liable to change soon.

-}
module KMonad.Action
  (
    KeyPred
  , Catch(..)
  , Trigger(..)
  , Timeout(..)
  , HookLocation(..)
  , Hook(..)

    -- * Lenses
  , HasHook(..)
  , HasTimeout(..)
  , HasTrigger(..)

    -- * Layer operations
    -- $lop
  , LayerOp(..)

    -- * MonadK
    -- $monadk
  , MonadKIO(..)
  , MonadK(..)
  , AnyK
  , Action(..)

    -- * Constituted actions
    -- $combs
  , my
  , matchMy
  , after
  , whenDone
  , await
  , awaitMy
  , tHookF
  , hookF
  , within
  , withinHeld
  )

where

import KMonad.Prelude hiding (timeout)

import KMonad.Keyboard
import KMonad.Util

--------------------------------------------------------------------------------
-- $keyfun

-- | Boolean isomorph signalling wether an event should be caught or not
data Catch = Catch | NoCatch deriving (Int -> Catch -> ShowS
[Catch] -> ShowS
Catch -> String
(Int -> Catch -> ShowS)
-> (Catch -> String) -> ([Catch] -> ShowS) -> Show Catch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Catch] -> ShowS
$cshowList :: [Catch] -> ShowS
show :: Catch -> String
$cshow :: Catch -> String
showsPrec :: Int -> Catch -> ShowS
$cshowsPrec :: Int -> Catch -> ShowS
Show, Catch -> Catch -> Bool
(Catch -> Catch -> Bool) -> (Catch -> Catch -> Bool) -> Eq Catch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Catch -> Catch -> Bool
$c/= :: Catch -> Catch -> Bool
== :: Catch -> Catch -> Bool
$c== :: Catch -> Catch -> Bool
Eq)

instance Semigroup Catch where
  NoCatch <> :: Catch -> Catch -> Catch
<> NoCatch = Catch
NoCatch
  _       <> _       = Catch
Catch

instance Monoid Catch where
  mempty :: Catch
mempty = Catch
NoCatch

-- | The packet used to trigger a KeyFun, containing info about the event and
-- how long since the Hook was registered.
data Trigger = Trigger
  { Trigger -> Milliseconds
_elapsed :: Milliseconds -- ^ Time elapsed since hook was registered
  , Trigger -> KeyEvent
_event   :: KeyEvent     -- ^ The key event triggering this call
  }
makeClassy ''Trigger


--------------------------------------------------------------------------------
-- $hook
--
-- The general structure of the 'Hook' record, that defines the most general way
-- of registering a 'KeyEvent' function.

-- | ADT signalling where to install a hook
data HookLocation
  = InputHook  -- ^ Install the hook immediately after receiving a 'KeyEvent'
  | OutputHook -- ^ Install the hook just before emitting a 'KeyEvent'
  deriving (HookLocation -> HookLocation -> Bool
(HookLocation -> HookLocation -> Bool)
-> (HookLocation -> HookLocation -> Bool) -> Eq HookLocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HookLocation -> HookLocation -> Bool
$c/= :: HookLocation -> HookLocation -> Bool
== :: HookLocation -> HookLocation -> Bool
$c== :: HookLocation -> HookLocation -> Bool
Eq, Int -> HookLocation -> ShowS
[HookLocation] -> ShowS
HookLocation -> String
(Int -> HookLocation -> ShowS)
-> (HookLocation -> String)
-> ([HookLocation] -> ShowS)
-> Show HookLocation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HookLocation] -> ShowS
$cshowList :: [HookLocation] -> ShowS
show :: HookLocation -> String
$cshow :: HookLocation -> String
showsPrec :: Int -> HookLocation -> ShowS
$cshowsPrec :: Int -> HookLocation -> ShowS
Show)

-- | A 'Timeout' value describes how long to wait and what to do upon timeout
data Timeout m = Timeout
  { Timeout m -> Milliseconds
_delay  :: Milliseconds -- ^ Delay before timeout action is triggered
  , Timeout m -> m ()
_action :: m ()         -- ^ Action to perform upon timeout
  }
makeClassy ''Timeout

-- | The content for 1 key hook
data Hook m = Hook
  { Hook m -> Maybe (Timeout m)
_hTimeout :: Maybe (Timeout m)  -- ^ Optional timeout machinery
  , Hook m -> Trigger -> m Catch
_keyH     :: Trigger -> m Catch -- ^ The function to call on the next 'KeyEvent'
  }
makeClassy ''Hook


--------------------------------------------------------------------------------
-- $lop
--
-- Operations that manipulate the layer-stack

-- | 'LayerOp' describes all the different layer-manipulations that KMonad
-- supports.
data LayerOp
  = PushLayer    LayerTag -- ^ Add a layer to the top of the stack
  | PopLayer     LayerTag -- ^ Remove the first occurence of a layer
  | SetBaseLayer LayerTag -- ^ Change the base-layer


--------------------------------------------------------------------------------
-- $monadk
--
-- The fundamental components that make up any 'KMonad.Button.Button' operation.

-- | 'MonadK' contains all the operations used to constitute button actions. It
-- encapsulates all the side-effects required to get everything running.
class Monad m => MonadKIO m where
  -- | Emit a KeyEvent to the OS
  emit       :: KeyEvent -> m ()
  -- | Pause the current thread for n milliseconds
  pause      :: Milliseconds -> m ()
  -- | Pause or unpause event processing
  hold       :: Bool -> m ()
  -- | Register a callback hook
  register   :: HookLocation -> Hook m -> m ()
  -- | Run a layer-stack manipulation
  layerOp    :: LayerOp -> m ()
  -- | Insert an event in the input queue
  inject     :: KeyEvent -> m ()
  -- | Run a shell-command
  shellCmd   :: Text -> m ()

-- | 'MonadKIO' contains the additional bindings that get added when we are
-- currently processing a button.
class MonadKIO m => MonadK m where
  -- | Access the keycode to which the current button is bound
  myBinding  :: m Keycode

-- | Type alias for `any monad that can perform MonadK actions`
type AnyK a = forall m. MonadK m => m a

-- | A newtype wrapper used to construct 'MonadK' actions
newtype Action = Action { Action -> forall (m :: * -> *). MonadK m => m ()
runAction :: AnyK ()}

--------------------------------------------------------------------------------
-- $util

-- | Create a KeyEvent matching pressing or releasing of the current button.
my :: MonadK m => Switch -> m KeyEvent
my :: Switch -> m KeyEvent
my s :: Switch
s = Switch -> Keycode -> KeyEvent
mkKeyEvent Switch
s (Keycode -> KeyEvent) -> m Keycode -> m KeyEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Keycode
forall (m :: * -> *). MonadK m => m Keycode
myBinding

-- | Register a simple hook without a timeout
hookF :: MonadKIO m => HookLocation -> (KeyEvent -> m Catch) -> m ()
hookF :: HookLocation -> (KeyEvent -> m Catch) -> m ()
hookF l :: HookLocation
l f :: KeyEvent -> m Catch
f = HookLocation -> Hook m -> m ()
forall (m :: * -> *). MonadKIO m => HookLocation -> Hook m -> m ()
register HookLocation
l (Hook m -> m ())
-> ((Trigger -> m Catch) -> Hook m) -> (Trigger -> m Catch) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Timeout m) -> (Trigger -> m Catch) -> Hook m
forall (m :: * -> *).
Maybe (Timeout m) -> (Trigger -> m Catch) -> Hook m
Hook Maybe (Timeout m)
forall a. Maybe a
Nothing ((Trigger -> m Catch) -> m ()) -> (Trigger -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \t :: Trigger
t -> KeyEvent -> m Catch
f (Trigger
tTrigger -> Getting KeyEvent Trigger KeyEvent -> KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting KeyEvent Trigger KeyEvent
forall c. HasTrigger c => Lens' c KeyEvent
event)

-- | Register a hook with a timeout
tHookF :: MonadK m
  => HookLocation         -- ^ Where to install the hook
  -> Milliseconds         -- ^ The timeout delay for the hook
  -> m ()                 -- ^ The action to perform on timeout
  -> (Trigger -> m Catch) -- ^ The action to perform on trigger
  -> m ()                 -- ^ The resulting action
tHookF :: HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
tHookF l :: HookLocation
l d :: Milliseconds
d a :: m ()
a f :: Trigger -> m Catch
f = HookLocation -> Hook m -> m ()
forall (m :: * -> *). MonadKIO m => HookLocation -> Hook m -> m ()
register HookLocation
l (Hook m -> m ()) -> Hook m -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (Timeout m) -> (Trigger -> m Catch) -> Hook m
forall (m :: * -> *).
Maybe (Timeout m) -> (Trigger -> m Catch) -> Hook m
Hook (Timeout m -> Maybe (Timeout m)
forall a. a -> Maybe a
Just (Timeout m -> Maybe (Timeout m)) -> Timeout m -> Maybe (Timeout m)
forall a b. (a -> b) -> a -> b
$ Milliseconds -> m () -> Timeout m
forall (m :: * -> *). Milliseconds -> m () -> Timeout m
Timeout Milliseconds
d m ()
a) Trigger -> m Catch
f

-- | Perform an action after a period of time has elapsed
--
-- This is essentially just a way to perform async actions using the KMonad hook
-- system.
after :: MonadK m
  => Milliseconds
  -> m ()
  -> m ()
after :: Milliseconds -> m () -> m ()
after d :: Milliseconds
d a :: m ()
a = do
  let rehook :: Trigger -> m Catch
rehook t :: Trigger
t = Milliseconds -> m () -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> m () -> m ()
after (Milliseconds
d Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
- Trigger
tTrigger
-> Getting Milliseconds Trigger Milliseconds -> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds Trigger Milliseconds
forall c. HasTrigger c => Lens' c Milliseconds
elapsed) m ()
a m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch
  HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
tHookF HookLocation
InputHook Milliseconds
d m ()
a Trigger -> m Catch
rehook

-- | Perform an action immediately after the current action is finished. NOTE:
-- there is no guarantee that another event doesn't outrace this, only that it
-- will happen as soon as the CPU gets to it.
whenDone :: MonadK m
  => m ()
  -> m ()
whenDone :: m () -> m ()
whenDone = Milliseconds -> m () -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> m () -> m ()
after 0


-- | Create a KeyPred that matches the Press or Release of the current button.
matchMy :: MonadK m => Switch -> m KeyPred
matchMy :: Switch -> m KeyPred
matchMy s :: Switch
s = KeyEvent -> KeyPred
forall a. Eq a => a -> a -> Bool
(==) (KeyEvent -> KeyPred) -> m KeyEvent -> m KeyPred
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Switch -> m KeyEvent
forall (m :: * -> *). MonadK m => Switch -> m KeyEvent
my Switch
s

-- | Wait for an event to match a predicate and then execute an action
await :: MonadKIO m => KeyPred -> (KeyEvent -> m Catch) -> m ()
await :: KeyPred -> (KeyEvent -> m Catch) -> m ()
await p :: KeyPred
p a :: KeyEvent -> m Catch
a = HookLocation -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
HookLocation -> (KeyEvent -> m Catch) -> m ()
hookF HookLocation
InputHook ((KeyEvent -> m Catch) -> m ()) -> (KeyEvent -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \e :: KeyEvent
e -> if KeyPred
p KeyEvent
e
  then KeyEvent -> m Catch
a KeyEvent
e
  else KeyPred -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await KeyPred
p KeyEvent -> m Catch
a m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch

-- | Execute an action on the detection of the Switch of the active button.
awaitMy :: MonadK m => Switch -> m Catch -> m ()
awaitMy :: Switch -> m Catch -> m ()
awaitMy s :: Switch
s a :: m Catch
a = Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
s m KeyPred -> (KeyPred -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (KeyPred -> (KeyEvent -> m Catch) -> m ())
-> (KeyEvent -> m Catch) -> KeyPred -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip KeyPred -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await (m Catch -> KeyEvent -> m Catch
forall a b. a -> b -> a
const m Catch
a)

-- | Try to call a function on a succesful match of a predicate within a certain
-- time period. On a timeout, perform an action.
within :: MonadK m
  => Milliseconds          -- ^ The time within which this filter is active
  -> m KeyPred             -- ^ The predicate used to find a match
  -> m ()                  -- ^ The action to call on timeout
  -> (Trigger -> m Catch)  -- ^ The action to call on a succesful match
  -> m ()                  -- ^ The resulting action
within :: Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within d :: Milliseconds
d p :: m KeyPred
p a :: m ()
a f :: Trigger -> m Catch
f = do
  KeyPred
p' <- m KeyPred
p
  -- define f' to run action on predicate match, or rehook on predicate mismatch
  let f' :: Trigger -> m Catch
f' t :: Trigger
t = if KeyPred
p' (Trigger
tTrigger -> Getting KeyEvent Trigger KeyEvent -> KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting KeyEvent Trigger KeyEvent
forall c. HasTrigger c => Lens' c KeyEvent
event)
        then Trigger -> m Catch
f Trigger
t
        else Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within (Milliseconds
d Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
- Trigger
tTrigger
-> Getting Milliseconds Trigger Milliseconds -> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds Trigger Milliseconds
forall c. HasTrigger c => Lens' c Milliseconds
elapsed) m KeyPred
p m ()
a Trigger -> m Catch
f m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch
  HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
tHookF HookLocation
InputHook Milliseconds
d m ()
a Trigger -> m Catch
f'

-- | Like `within`, but acquires a hold when starting, and releases when done
withinHeld :: MonadK m
  => Milliseconds          -- ^ The time within which this filter is active
  -> m KeyPred             -- ^ The predicate used to find a match
  -> m ()                  -- ^ The action to call on timeout
  -> (Trigger -> m Catch)  -- ^ The action to call on a succesful match
  -> m ()                  -- ^ The resulting action
withinHeld :: Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
withinHeld d :: Milliseconds
d p :: m KeyPred
p a :: m ()
a f :: Trigger -> m Catch
f = do
  Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
True
  Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within Milliseconds
d m KeyPred
p (m ()
a m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False) (\x :: Trigger
x -> Trigger -> m Catch
f Trigger
x m Catch -> m () -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False)