{-|
Module      : KMonad.App.Keymap
Description : Implementation of mapping key-presses to button actions
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

In KMonad we handle all releases (and some other actions) via callback
mechanisms. It is the button-presses that get handled through a keymap. It is
the 'Keymap' component that manages the keymap state and ensures that
incoming events are mapped to

-}
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

--------------------------------------------------------------------------------
-- $env
--


-- | The 'Keymap' environment containing the current keymap
--
-- NOTE: Since the 'Keymap' will never have to deal with anything
-- asynchronously we can simply use 'IORef's here.
data Keymap = Keymap
  { Keymap -> IORef (LMap BEnv)
_stack :: IORef (LMap BEnv)
  , Keymap -> IORef LayerTag
_baseL :: IORef LayerTag
  }
makeClassy ''Keymap

-- | Create a 'Keymap' from a 'Keymap' of uninitialized 'Button's and a
-- tag indicating which layer should start as the base.
mkKeymap' :: MonadUnliftIO m
  => LayerTag    -- ^ The initial base layer
  -> LMap Button -- ^ The keymap of 'Button's
  -> 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

-- | Create a 'Keymap' but do so in the context of a 'ContT' monad to ease nesting.
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


--------------------------------------------------------------------------------
-- $op
--
-- The following code describes how we add and remove layers from the
-- 'Keymap'.

-- | Print a header message followed by an enumeration of the layer-stack
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"

-- | Perform operations on the layer-stack
layerOp :: (HasLogFunc e)
  => Keymap -- ^ The 'Keymap' environment
  -> LayerOp      -- ^ The 'LayerOp' to perform
  -> RIO e ()     -- ^ The resulting action
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


--------------------------------------------------------------------------------
-- $run
--
-- How we use the 'Keymap' to handle events.

-- | Lookup the 'BEnv' currently mapped to the key press.
lookupKey :: MonadIO m
  => Keymap   -- ^ The 'Keymap' to lookup in
  -> Keycode        -- ^ The 'Keycode' to lookup
  -> m (Maybe BEnv) -- ^ The resulting action
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