module KMonad.App.Keymap
( Keymap
, mkKeymap
, layerOp
, lookupKey
)
where
import KMonad.Prelude
import KMonad.Action hiding (layerOp)
import KMonad.Button
import KMonad.Keyboard
import KMonad.App.BEnv
import qualified Data.LayerStack as Ls
data Keymap = Keymap
{ Keymap -> IORef (LMap BEnv)
_stack :: IORef (LMap BEnv)
, Keymap -> IORef LayerTag
_baseL :: IORef LayerTag
}
makeClassy ''Keymap
mkKeymap' :: MonadUnliftIO m
=> LayerTag
-> LMap Button
-> m Keymap
mkKeymap' :: LayerTag -> LMap Button -> m Keymap
mkKeymap' n :: LayerTag
n m :: LMap Button
m = do
LMap BEnv
envs <- LMap Button
m LMap Button -> (LMap Button -> m (LMap BEnv)) -> m (LMap BEnv)
forall a b. a -> (a -> b) -> b
& (HashMap (LayerTag, Keycode) Button
-> m (HashMap (LayerTag, Keycode) BEnv))
-> LMap Button -> m (LMap BEnv)
forall l k1 a1 k2 a2.
Lens
(LayerStack l k1 a1)
(LayerStack l k2 a2)
(HashMap (l, k1) a1)
(HashMap (l, k2) a2)
Ls.items ((HashMap (LayerTag, Keycode) Button
-> m (HashMap (LayerTag, Keycode) BEnv))
-> LMap Button -> m (LMap BEnv))
-> (Indexed (LayerTag, Keycode) Button (m BEnv)
-> HashMap (LayerTag, Keycode) Button
-> m (HashMap (LayerTag, Keycode) BEnv))
-> Indexed (LayerTag, Keycode) Button (m BEnv)
-> LMap Button
-> m (LMap BEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Indexed (LayerTag, Keycode) Button (m BEnv)
-> HashMap (LayerTag, Keycode) Button
-> m (HashMap (LayerTag, Keycode) BEnv)
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
itraversed (Indexed (LayerTag, Keycode) Button (m BEnv)
-> LMap Button -> m (LMap BEnv))
-> ((LayerTag, Keycode) -> Button -> m BEnv)
-> LMap Button
-> m (LMap BEnv)
forall k i (f :: k -> *) s (t :: k) a (b :: k).
Over (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t
%%@~ \(_, c :: Keycode
c) b :: Button
b -> Button -> Keycode -> m BEnv
forall (m :: * -> *). MonadIO m => Button -> Keycode -> m BEnv
initBEnv Button
b Keycode
c
IORef (LMap BEnv) -> IORef LayerTag -> Keymap
Keymap (IORef (LMap BEnv) -> IORef LayerTag -> Keymap)
-> m (IORef (LMap BEnv)) -> m (IORef LayerTag -> Keymap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LMap BEnv -> m (IORef (LMap BEnv))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef LMap BEnv
envs m (IORef LayerTag -> Keymap) -> m (IORef LayerTag) -> m Keymap
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LayerTag -> m (IORef LayerTag)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef LayerTag
n
mkKeymap :: MonadUnliftIO m => LayerTag -> LMap Button -> ContT r m Keymap
mkKeymap :: LayerTag -> LMap Button -> ContT r m Keymap
mkKeymap n :: LayerTag
n = m Keymap -> ContT r m Keymap
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Keymap -> ContT r m Keymap)
-> (LMap Button -> m Keymap) -> LMap Button -> ContT r m Keymap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayerTag -> LMap Button -> m Keymap
forall (m :: * -> *).
MonadUnliftIO m =>
LayerTag -> LMap Button -> m Keymap
mkKeymap' LayerTag
n
debugReport :: HasLogFunc e => Keymap -> Utf8Builder -> RIO e ()
debugReport :: Keymap -> Utf8Builder -> RIO e ()
debugReport h :: Keymap
h hdr :: Utf8Builder
hdr = do
[LayerTag]
st <- Getting [LayerTag] (LMap BEnv) [LayerTag]
-> LMap BEnv -> [LayerTag]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [LayerTag] (LMap BEnv) [LayerTag]
forall l k1 a1. Lens' (LayerStack l k1 a1) [l]
Ls.stack (LMap BEnv -> [LayerTag]) -> RIO e (LMap BEnv) -> RIO e [LayerTag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (IORef (LMap BEnv) -> RIO e (LMap BEnv))
-> IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall a b. (a -> b) -> a -> b
$ Keymap
hKeymap
-> Getting (IORef (LMap BEnv)) Keymap (IORef (LMap BEnv))
-> IORef (LMap BEnv)
forall s a. s -> Getting a s a -> a
^.Getting (IORef (LMap BEnv)) Keymap (IORef (LMap BEnv))
forall c. HasKeymap c => Lens' c (IORef (LMap BEnv))
stack)
let ub :: Utf8Builder
ub = ((Int, LayerTag) -> Utf8Builder)
-> [(Int, LayerTag)] -> Utf8Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(i :: Int
i, n :: LayerTag
n) -> " " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
i
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ". " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
n Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "\n")
([Int] -> [LayerTag] -> [(Int, LayerTag)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([1..] :: [Int]) [LayerTag]
st)
LayerTag
ls <- IORef LayerTag -> RIO e LayerTag
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (Keymap
hKeymap
-> Getting (IORef LayerTag) Keymap (IORef LayerTag)
-> IORef LayerTag
forall s a. s -> Getting a s a -> a
^.Getting (IORef LayerTag) Keymap (IORef LayerTag)
forall c. HasKeymap c => Lens' c (IORef LayerTag)
baseL)
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
hdr Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
ub Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "Base-layer: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
ls Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> "\n"
layerOp :: (HasLogFunc e)
=> Keymap
-> LayerOp
-> RIO e ()
layerOp :: Keymap -> LayerOp -> RIO e ()
layerOp h :: Keymap
h o :: LayerOp
o = let km :: IORef (LMap BEnv)
km = Keymap
hKeymap
-> Getting (IORef (LMap BEnv)) Keymap (IORef (LMap BEnv))
-> IORef (LMap BEnv)
forall s a. s -> Getting a s a -> a
^.Getting (IORef (LMap BEnv)) Keymap (IORef (LMap BEnv))
forall c. HasKeymap c => Lens' c (IORef (LMap BEnv))
stack in case LayerOp
o of
(PushLayer n :: LayerTag
n) -> do
LayerTag
-> LMap BEnv -> Either (LayerStackError LayerTag) (LMap BEnv)
forall l k a.
(CanKey l, CanKey k) =>
l
-> LayerStack l k a
-> Either (LayerStackError l) (LayerStack l k a)
Ls.pushLayer LayerTag
n (LMap BEnv -> Either (LayerStackError LayerTag) (LMap BEnv))
-> RIO e (LMap BEnv)
-> RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (LMap BEnv)
km RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
-> (Either (LayerStackError LayerTag) (LMap BEnv) -> RIO e ())
-> RIO e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left e :: LayerStackError LayerTag
e -> LayerStackError LayerTag -> RIO e ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO LayerStackError LayerTag
e
Right m' :: LMap BEnv
m' -> IORef (LMap BEnv) -> LMap BEnv -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (LMap BEnv)
km LMap BEnv
m'
Keymap -> Utf8Builder -> RIO e ()
forall e. HasLogFunc e => Keymap -> Utf8Builder -> RIO e ()
debugReport Keymap
h (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Pushed layer to stack: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
n
(PopLayer n :: LayerTag
n) -> do
LayerTag
-> LMap BEnv -> Either (LayerStackError LayerTag) (LMap BEnv)
forall l k a.
(CanKey l, CanKey k) =>
l
-> LayerStack l k a
-> Either (LayerStackError l) (LayerStack l k a)
Ls.popLayer LayerTag
n (LMap BEnv -> Either (LayerStackError LayerTag) (LMap BEnv))
-> RIO e (LMap BEnv)
-> RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (LMap BEnv)
km RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
-> (Either (LayerStackError LayerTag) (LMap BEnv) -> RIO e ())
-> RIO e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left e :: LayerStackError LayerTag
e -> LayerStackError LayerTag -> RIO e ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO LayerStackError LayerTag
e
Right m' :: LMap BEnv
m' -> IORef (LMap BEnv) -> LMap BEnv -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (LMap BEnv)
km LMap BEnv
m'
Keymap -> Utf8Builder -> RIO e ()
forall e. HasLogFunc e => Keymap -> Utf8Builder -> RIO e ()
debugReport Keymap
h (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Popped layer from stack: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
n
(SetBaseLayer n :: LayerTag
n) -> do
(LayerTag
n LayerTag -> HashSet LayerTag -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) (HashSet LayerTag -> Bool)
-> (LMap BEnv -> HashSet LayerTag) -> LMap BEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (HashSet LayerTag) (LMap BEnv) (HashSet LayerTag)
-> LMap BEnv -> HashSet LayerTag
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (HashSet LayerTag) (LMap BEnv) (HashSet LayerTag)
forall l k1 a1. Lens' (LayerStack l k1 a1) (HashSet l)
Ls.maps (LMap BEnv -> Bool) -> RIO e (LMap BEnv) -> RIO e Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (LMap BEnv)
km) RIO e Bool -> (Bool -> RIO e ()) -> RIO e ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
True -> IORef LayerTag -> LayerTag -> RIO e ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (Keymap
hKeymap
-> Getting (IORef LayerTag) Keymap (IORef LayerTag)
-> IORef LayerTag
forall s a. s -> Getting a s a -> a
^.Getting (IORef LayerTag) Keymap (IORef LayerTag)
forall c. HasKeymap c => Lens' c (IORef LayerTag)
baseL) LayerTag
n
False -> LayerStackError LayerTag -> RIO e ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (LayerStackError LayerTag -> RIO e ())
-> LayerStackError LayerTag -> RIO e ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerStackError LayerTag
forall l. l -> LayerStackError l
Ls.LayerDoesNotExist LayerTag
n
Keymap -> Utf8Builder -> RIO e ()
forall e. HasLogFunc e => Keymap -> Utf8Builder -> RIO e ()
debugReport Keymap
h (Utf8Builder -> RIO e ()) -> Utf8Builder -> RIO e ()
forall a b. (a -> b) -> a -> b
$ "Set base layer to: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
n
lookupKey :: MonadIO m
=> Keymap
-> Keycode
-> m (Maybe BEnv)
lookupKey :: Keymap -> Keycode -> m (Maybe BEnv)
lookupKey h :: Keymap
h c :: Keycode
c = do
LMap BEnv
m <- IORef (LMap BEnv) -> m (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (IORef (LMap BEnv) -> m (LMap BEnv))
-> IORef (LMap BEnv) -> m (LMap BEnv)
forall a b. (a -> b) -> a -> b
$ Keymap
hKeymap
-> Getting (IORef (LMap BEnv)) Keymap (IORef (LMap BEnv))
-> IORef (LMap BEnv)
forall s a. s -> Getting a s a -> a
^.Getting (IORef (LMap BEnv)) Keymap (IORef (LMap BEnv))
forall c. HasKeymap c => Lens' c (IORef (LMap BEnv))
stack
LayerTag
f <- IORef LayerTag -> m LayerTag
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef (IORef LayerTag -> m LayerTag) -> IORef LayerTag -> m LayerTag
forall a b. (a -> b) -> a -> b
$ Keymap
hKeymap
-> Getting (IORef LayerTag) Keymap (IORef LayerTag)
-> IORef LayerTag
forall s a. s -> Getting a s a -> a
^.Getting (IORef LayerTag) Keymap (IORef LayerTag)
forall c. HasKeymap c => Lens' c (IORef LayerTag)
baseL
Maybe BEnv -> m (Maybe BEnv)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe BEnv -> m (Maybe BEnv)) -> Maybe BEnv -> m (Maybe BEnv)
forall a b. (a -> b) -> a -> b
$ case LMap BEnv
m LMap BEnv -> Getting (First BEnv) (LMap BEnv) BEnv -> Maybe BEnv
forall s a. s -> Getting (First a) s a -> Maybe a
^? Keycode -> Fold (LMap BEnv) BEnv
forall l k a.
(CanKey l, CanKey k) =>
k -> Fold (LayerStack l k a) a
Ls.atKey Keycode
c of
Nothing -> LMap BEnv
m LMap BEnv -> Getting (First BEnv) (LMap BEnv) BEnv -> Maybe BEnv
forall s a. s -> Getting (First a) s a -> Maybe a
^? LayerTag -> Keycode -> Fold (LMap BEnv) BEnv
forall l k a.
(CanKey l, CanKey k) =>
l -> k -> Fold (LayerStack l k a) a
Ls.inLayer LayerTag
f Keycode
c
benv :: Maybe BEnv
benv -> Maybe BEnv
benv