{-|
Module      : KMonad.Model.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.Model.Keymap
  ( Keymap
  , mkKeymap
  , layerOp
  , lookupKey
  )
where


import KMonad.Prelude

import KMonad.Model.Action hiding (layerOp)
import KMonad.Model.Button
import KMonad.Keyboard
import KMonad.Model.BEnv

import qualified KMonad.Util.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' :: forall (m :: * -> *).
MonadUnliftIO m =>
LayerTag -> LMap Button -> m Keymap
mkKeymap' LayerTag
n 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 (f :: * -> *).
Functor f =>
(HashMap (l, k1) a1 -> f (HashMap (l, k2) a2))
-> LayerStack l k1 a1 -> f (LayerStack 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
IndexedTraversal
  (LayerTag, Keycode)
  (HashMap (LayerTag, Keycode) Button)
  (HashMap (LayerTag, Keycode) BEnv)
  Button
  BEnv
itraversed (Indexed (LayerTag, Keycode) Button (m BEnv)
 -> LMap Button -> m (LMap BEnv))
-> ((LayerTag, Keycode) -> Button -> m BEnv)
-> LMap Button
-> m (LMap BEnv)
forall {k1} i (f :: k1 -> *) s (t :: k1) a (b :: k1).
Over (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t
%%@~ \(LayerTag
_, Keycode
c) 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 a b. m (a -> b) -> m a -> m b
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 :: forall (m :: * -> *) r.
MonadUnliftIO m =>
LayerTag -> LMap Button -> ContT r m Keymap
mkKeymap LayerTag
n = m Keymap -> ContT r m Keymap
forall (m :: * -> *) a. Monad m => m a -> ContT r m a
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 :: forall e. HasLogFunc e => Keymap -> Utf8Builder -> RIO e ()
debugReport Keymap
h 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 k a (f :: * -> *).
Functor f =>
([l] -> f [l]) -> LayerStack l k a -> f (LayerStack l k a)
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 (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))
Lens' Keymap (IORef (LMap BEnv))
stack)
  let ub :: Utf8Builder
ub = ((Int, LayerTag) -> Utf8Builder)
-> [(Int, LayerTag)] -> Utf8Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Int
i, LayerTag
n) -> Utf8Builder
" "  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 -> 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
<> Utf8Builder
"\n")
             ([Int] -> [LayerTag] -> [(Int, LayerTag)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
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)
Lens' Keymap (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
<> Utf8Builder
"\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
ub Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"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
<> Utf8Builder
"\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 :: forall e. HasLogFunc e => Keymap -> LayerOp -> RIO e ()
layerOp Keymap
h 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))
Lens' Keymap (IORef (LMap BEnv))
stack in case LayerOp
o of
  (PushLayer LayerTag
n) -> do
    (IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (LMap BEnv)
km RIO e (LMap BEnv)
-> (LMap BEnv -> Either (LayerStackError LayerTag) (LMap BEnv))
-> RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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) RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
-> (Either (LayerStackError LayerTag) (LMap BEnv) -> RIO e ())
-> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left LayerStackError LayerTag
e   -> LayerStackError LayerTag -> RIO e ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO LayerStackError LayerTag
e
      Right 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
$ Utf8Builder
"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 LayerTag
n) -> do
    (IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (LMap BEnv)
km RIO e (LMap BEnv)
-> (LMap BEnv -> Either (LayerStackError LayerTag) (LMap BEnv))
-> RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> 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) RIO e (Either (LayerStackError LayerTag) (LMap BEnv))
-> (Either (LayerStackError LayerTag) (LMap BEnv) -> RIO e ())
-> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (Ls.LayerNotOnStack LayerTag
_) -> do
        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
$ Utf8Builder
"WARNING: Tried popping layer that was not on stack " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> LayerTag -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display LayerTag
n
      Left LayerStackError LayerTag
e                      -> LayerStackError LayerTag -> RIO e ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO LayerStackError LayerTag
e
      Right LMap BEnv
m'                    -> do
        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
$ Utf8Builder
"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 LayerTag
n) -> do
    (IORef (LMap BEnv) -> RIO e (LMap BEnv)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (LMap BEnv)
km RIO e (LMap BEnv) -> (LMap BEnv -> Bool) -> RIO e Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (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 k a (f :: * -> *).
Functor f =>
(HashSet l -> f (HashSet l))
-> LayerStack l k a -> f (LayerStack l k a)
Ls.maps (LMap BEnv -> HashSet LayerTag)
-> (HashSet LayerTag -> Bool) -> LMap BEnv -> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (LayerTag
n LayerTag -> HashSet LayerTag -> Bool
forall a. Eq a => a -> HashSet a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`))) RIO e Bool -> (Bool -> RIO e ()) -> RIO e ()
forall a b. RIO e a -> (a -> RIO e b) -> RIO e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
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)
Lens' Keymap (IORef LayerTag)
baseL) LayerTag
n
      Bool
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
$ Utf8Builder
"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 :: forall (m :: * -> *).
MonadIO m =>
Keymap -> Keycode -> m (Maybe BEnv)
lookupKey Keymap
h 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))
Lens' Keymap (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)
Lens' Keymap (IORef LayerTag)
baseL

  Maybe BEnv -> m (Maybe BEnv)
forall a. a -> m a
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
    Maybe BEnv
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
    Maybe BEnv
benv    -> Maybe BEnv
benv