{-|
Module      : KMonad.Model.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.Model.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
$cshowsPrec :: Int -> Catch -> ShowS
showsPrec :: Int -> Catch -> ShowS
$cshow :: Catch -> String
show :: Catch -> String
$cshowList :: [Catch] -> ShowS
showList :: [Catch] -> ShowS
Show, Catch -> Catch -> Bool
(Catch -> Catch -> Bool) -> (Catch -> Catch -> Bool) -> Eq Catch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Catch -> Catch -> Bool
== :: Catch -> Catch -> Bool
$c/= :: Catch -> Catch -> Bool
/= :: Catch -> Catch -> Bool
Eq)

instance Semigroup Catch where
  Catch
NoCatch <> :: Catch -> Catch -> Catch
<> Catch
NoCatch = Catch
NoCatch
  Catch
_       <> Catch
_       = 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
$c== :: HookLocation -> HookLocation -> Bool
== :: HookLocation -> HookLocation -> Bool
$c/= :: HookLocation -> HookLocation -> Bool
/= :: 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
$cshowsPrec :: Int -> HookLocation -> ShowS
showsPrec :: Int -> HookLocation -> ShowS
$cshow :: HookLocation -> String
show :: HookLocation -> String
$cshowList :: [HookLocation] -> ShowS
showList :: [HookLocation] -> ShowS
Show)

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

-- | The content for 1 key hook
data Hook m = Hook
  { forall (m :: * -> *). Hook m -> Maybe (Timeout m)
_hTimeout :: Maybe (Timeout m)  -- ^ Optional timeout machinery
  , forall (m :: * -> *). 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.Model.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 -> AnyK ()
runAction :: AnyK ()}

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

-- | Create a KeyEvent matching pressing or releasing of the current button.
my :: MonadK m => Switch -> m KeyEvent
my :: forall (m :: * -> *). MonadK m => Switch -> m KeyEvent
my 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 :: forall (m :: * -> *).
MonadKIO m =>
HookLocation -> (KeyEvent -> m Catch) -> m ()
hookF HookLocation
l 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
$ \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
Lens' Trigger 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 :: forall (m :: * -> *).
MonadK m =>
HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
tHookF HookLocation
l Milliseconds
d m ()
a 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 :: forall (m :: * -> *). MonadK m => Milliseconds -> m () -> m ()
after Milliseconds
d m ()
a = do
  let rehook :: Trigger -> m Catch
rehook 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
Lens' Trigger Milliseconds
elapsed) m ()
a m () -> Catch -> m Catch
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 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 :: forall (m :: * -> *). MonadK m => m () -> m ()
whenDone = Milliseconds -> m () -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> m () -> m ()
after Milliseconds
0


-- | Create a KeyPred that matches the Press or Release of the current button.
matchMy :: MonadK m => Switch -> m KeyPred
matchMy :: forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy 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 :: forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await KeyPred
p 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
$ \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 () -> Catch -> m Catch
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Catch
NoCatch

-- | Execute an action on the detection of the Switch of the active button.
awaitMy :: MonadK m => Switch -> m Catch -> m ()
awaitMy :: forall (m :: * -> *). MonadK m => Switch -> m Catch -> m ()
awaitMy Switch
s m Catch
a = Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
s m KeyPred -> (KeyPred -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
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 :: forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within Milliseconds
d m KeyPred
p m ()
a 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' 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
Lens' Trigger 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
Lens' Trigger Milliseconds
elapsed) m KeyPred
p m ()
a Trigger -> m Catch
f m () -> Catch -> m Catch
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 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 :: forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
withinHeld Milliseconds
d m KeyPred
p m ()
a 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 a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False) (\Trigger
x -> Trigger -> m Catch
f Trigger
x m Catch -> m () -> m Catch
forall a b. m a -> m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False)