module KMonad.Model.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
$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
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
$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)
data Timeout m = Timeout
{ forall (m :: * -> *). Timeout m -> Milliseconds
_delay :: Milliseconds
, forall (m :: * -> *). Timeout m -> m ()
_action :: m ()
}
makeClassy ''Timeout
data Hook m = Hook
{ forall (m :: * -> *). Hook m -> Maybe (Timeout m)
_hTimeout :: Maybe (Timeout m)
, forall (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 -> AnyK ()
runAction :: AnyK ()}
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
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)
tHookF :: MonadK m
=> HookLocation
-> Milliseconds
-> m ()
-> (Trigger -> m Catch)
-> m ()
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
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
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
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
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
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)
within :: MonadK m
=> Milliseconds
-> m KeyPred
-> m ()
-> (Trigger -> m Catch)
-> m ()
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
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'
withinHeld :: MonadK m
=> Milliseconds
-> m KeyPred
-> m ()
-> (Trigger -> m Catch)
-> m ()
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)