module KMonad.Action
(
KeyPred
, Catch(..)
, Trigger(..)
, Timeout(..)
, HookLocation(..)
, Hook(..)
, HasHook(..)
, HasTimeout(..)
, HasTrigger(..)
, LayerOp(..)
, MonadKIO(..)
, MonadK(..)
, AnyK
, Action(..)
, my
, matchMy
, after
, whenDone
, await
, awaitMy
, tHookF
, hookF
, within
, withinHeld
)
where
import KMonad.Prelude hiding (timeout)
import KMonad.Keyboard
import KMonad.Util
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
data Trigger = Trigger
{ Trigger -> Milliseconds
_elapsed :: Milliseconds
, Trigger -> KeyEvent
_event :: KeyEvent
}
makeClassy ''Trigger
data HookLocation
= InputHook
| OutputHook
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)
data Timeout m = Timeout
{ Timeout m -> Milliseconds
_delay :: Milliseconds
, Timeout m -> m ()
_action :: m ()
}
makeClassy ''Timeout
data Hook m = Hook
{ Hook m -> Maybe (Timeout m)
_hTimeout :: Maybe (Timeout m)
, Hook m -> Trigger -> m Catch
_keyH :: Trigger -> m Catch
}
makeClassy ''Hook
data LayerOp
= PushLayer LayerTag
| PopLayer LayerTag
| SetBaseLayer LayerTag
class Monad m => MonadKIO m where
emit :: KeyEvent -> m ()
pause :: Milliseconds -> m ()
hold :: Bool -> m ()
register :: HookLocation -> Hook m -> m ()
layerOp :: LayerOp -> m ()
inject :: KeyEvent -> m ()
shellCmd :: Text -> m ()
class MonadKIO m => MonadK m where
myBinding :: m Keycode
type AnyK a = forall m. MonadK m => m a
newtype Action = Action { Action -> forall (m :: * -> *). MonadK m => m ()
runAction :: AnyK ()}
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
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)
tHookF :: MonadK m
=> HookLocation
-> Milliseconds
-> m ()
-> (Trigger -> m Catch)
-> m ()
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
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
whenDone :: MonadK m
=> m ()
-> m ()
whenDone :: m () -> m ()
whenDone = Milliseconds -> m () -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> m () -> m ()
after 0
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
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
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)
within :: MonadK m
=> Milliseconds
-> m KeyPred
-> m ()
-> (Trigger -> m Catch)
-> m ()
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
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'
withinHeld :: MonadK m
=> Milliseconds
-> m KeyPred
-> m ()
-> (Trigger -> m Catch)
-> m ()
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)