KeyConfig.hs

-- | This module provides 'KeyConfig' and associated functions. A
-- 'KeyConfig' is the basis for the custom keybinding system in this
-- library.
--
-- To get started, see 'newKeyConfig'. Once a 'KeyConfig' has been
-- constructed, see 'Brick.Keybindings.KeyHandlerMap.keyDispatcher'.
--
-- Since a key configuration can have keys bound to multiple events, it
-- is the application author's responsibility to check for collisions
-- since the nature of the collisions will depend on how the application
-- is implemented. To check for collisions, use the result of
-- 'keyEventMappings'.
module Brick.Keybindings.KeyConfig
  ( KeyConfig
  , newKeyConfig
  , BindingState(..)

  -- * Specifying bindings
  , Binding(..)
  , ToBinding(..)
  , binding
  , fn
  , meta
  , ctrl
  , shift

  -- * Querying KeyConfigs
  , firstDefaultBinding
  , firstActiveBinding
  , allDefaultBindings
  , allActiveBindings
  , keyEventMappings

  -- * Misc
  , keyConfigEvents
  , lookupKeyConfigBindings
  )
where

import Data.List (nub)
import qualified Data.Map.Strict as M
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import qualified Data.Set as S
import Data.Maybe (fromMaybe, listToMaybe, catMaybes)
import qualified Graphics.Vty as Vty

import Brick.Keybindings.KeyEvents

-- | A key binding.
--
-- The easiest way to express 'Binding's is to use the helper functions
-- in this module that work with instances of 'ToBinding', e.g.
--
-- @
-- let ctrlB = 'ctrl' \'b\'
--     shiftX = 'shift' \'x\'
--     ctrlMetaK = 'ctrl' $ 'meta' \'k\'
--     -- Or with Vty keys directly:
--     ctrlDown = 'ctrl' 'Graphics.Vty.Input.KDown'
-- @
data Binding =
    Binding { kbKey :: Vty.Key
            -- ^ The key itself.
            , kbMods :: S.Set Vty.Modifier
            -- ^ The set of modifiers.
            } deriving (Eq, Show, Ord)

-- | Construct a 'Binding'. Modifier order is ignored.
binding :: Vty.Key -> [Vty.Modifier] -> Binding
binding k mods =
    Binding { kbKey = k
            , kbMods = S.fromList mods
            }

-- | An explicit configuration of key bindings for a key event.
data BindingState =
    BindingList [Binding]
    -- ^ Bind the event to the specified list of bindings.
    | Unbound
    -- ^ Disable all bindings for the event, including default bindings.
    deriving (Show, Eq, Ord)

-- | A configuration of custom key bindings. A 'KeyConfig'
-- stores everything needed to resolve a key event into one or
-- more key bindings. Make a 'KeyConfig' with 'newKeyConfig',
-- then use it to dispatch to 'KeyEventHandler's with
-- 'Brick.Keybindings.KeyHandlerMap.keyDispatcher'.
--
-- Make a new 'KeyConfig' with 'newKeyConfig'.
--
-- A 'KeyConfig' stores:
--
-- * A collection of named key events, mapping the event type @k@ to
--   'Text' labels.
-- * For each event @k@, optionally store a list of default key bindings
--   for that event.
-- * An optional customized binding list for each event, setting the
--   event to either 'Unbound' or providing explicit overridden bindings
--   with 'BindingList'.
data KeyConfig k =
    KeyConfig { keyConfigCustomBindings :: [(k, BindingState)]
              -- ^ The list of custom binding states for events with
              -- custom bindings. We use a list to ensure that we
              -- preserve key bindings for keys that are mapped to more
              -- than one event. This may be valid or invalid depending
              -- on the events in question; whether those bindings
              -- constitute a collision is up to the application
              -- developer to check.
              , keyConfigEvents :: KeyEvents k
              -- ^ The base mapping of events and their names that is
              -- used in this configuration.
              , keyConfigDefaultBindings :: M.Map k [Binding]
              -- ^ A mapping of events and their default key bindings,
              -- if any.
              }
              deriving (Show, Eq)

-- | Build a 'KeyConfig' with the specified 'KeyEvents' event-to-name
-- mapping, list of default bindings by event, and list of custom
-- bindings by event.
newKeyConfig :: (Ord k)
             => KeyEvents k
             -- ^ The base mapping of key events and names to use.
             -> [(k, [Binding])]
             -- ^ Default bindings by key event, such as from a
             -- configuration file or embedded code. Optional on a
             -- per-event basis.
             -> [(k, BindingState)]
             -- ^ Custom bindings by key event, such as from a
             -- configuration file. Explicitly setting an event to
             -- 'Unbound' here has the effect of disabling its default
             -- bindings. Optional on a per-event basis. Note that this
             -- function does not check for collisions since it is up to
             -- the application to determine whether a key bound to more
             -- than one event constitutes a collision!
             -> KeyConfig k
newKeyConfig evs defaults bindings =
    KeyConfig { keyConfigCustomBindings = bindings
              , keyConfigEvents = evs
              , keyConfigDefaultBindings = M.fromList defaults
              }

-- | Return a list of mappings including each key bound to any event
-- combined with the list of events to which it is bound. This is useful
-- for identifying problematic key binding collisions. Since key binding
-- collisions cannot be determined in general, we leave it up to the
-- application author to determine which key-to-event bindings are
-- problematic.
keyEventMappings :: (Ord k, Eq k) => KeyConfig k -> [(Binding, S.Set k)]
keyEventMappings kc = M.toList resultMap
    where
        -- Get all default bindings
        defaultBindings = M.toList $ keyConfigDefaultBindings kc
        -- Get all explicitly unbound events
        explicitlyUnboundEvents = fmap fst $ filter ((== Unbound) . snd) $ keyConfigCustomBindings kc
        -- Remove explicitly unbound events from the default set of
        -- bindings
        defaultBindingsWithoutUnbound = filter ((`notElem` explicitlyUnboundEvents) . fst) defaultBindings
        -- Now get customized binding lists
        customizedKeybindingLists = catMaybes $ (flip fmap) (keyConfigCustomBindings kc) $ \(k, bState) -> do
            case bState of
                Unbound -> Nothing
                BindingList bs -> Just (k, bs)
        -- Now build a map from binding to event list
        allPairs = defaultBindingsWithoutUnbound <>
                   customizedKeybindingLists
        addBindings m (ev, bs) =
            M.unionWith S.union m $ M.fromList [(b, S.singleton ev) | b <- bs]
        resultMap = foldl addBindings mempty allPairs

-- | Look up the binding state for the specified event. This returns
-- 'Nothing' when the event has no explicitly configured custom
-- 'BindingState'.
lookupKeyConfigBindings :: (Ord k) => KeyConfig k -> k -> Maybe BindingState
lookupKeyConfigBindings kc e = lookup e $ keyConfigCustomBindings kc

-- | A convenience function to return the first result of
-- 'allDefaultBindings', if any.
firstDefaultBinding :: (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding
firstDefaultBinding kc ev = do
    bs <- M.lookup ev (keyConfigDefaultBindings kc)
    case bs of
        (b:_) -> Just b
        _ -> Nothing

-- | Returns the list of default bindings for the specified event,
-- irrespective of whether the event has been explicitly configured with
-- other bindings or set to 'Unbound'.
allDefaultBindings :: (Ord k) => KeyConfig k -> k -> [Binding]
allDefaultBindings kc ev =
    fromMaybe [] $ M.lookup ev (keyConfigDefaultBindings kc)

-- | A convenience function to return the first result of
-- 'allActiveBindings', if any.
firstActiveBinding :: (Show k, Ord k) => KeyConfig k -> k -> Maybe Binding
firstActiveBinding kc ev = listToMaybe $ allActiveBindings kc ev

-- | Return all active key bindings for the specified event. This
-- returns customized bindings if any have been set in the 'KeyConfig',
-- no bindings if the event has been explicitly set to 'Unbound', or the
-- default bindings if the event is absent from the customized bindings.
allActiveBindings :: (Show k, Ord k) => KeyConfig k -> k -> [Binding]
allActiveBindings kc ev = nub foundBindings
    where
        defaultBindings = allDefaultBindings kc ev
        foundBindings = case lookupKeyConfigBindings kc ev of
            Just (BindingList bs) -> bs
            Just Unbound -> []
            Nothing -> defaultBindings

-- | The class of types that can form the basis of 'Binding's.
--
-- This is provided to make it easy to write and modify bindings in less
-- verbose ways.
class ToBinding a where
    -- | Binding constructor.
    bind :: a -> Binding

instance ToBinding Vty.Key where
    bind k = Binding { kbMods = mempty, kbKey = k }

instance ToBinding Char where
    bind = bind . Vty.KChar

instance ToBinding Binding where
    bind = id

addModifier :: (ToBinding a) => Vty.Modifier -> a -> Binding
addModifier m val =
    let b = bind val
    in b { kbMods = S.insert m (kbMods b) }

-- | Add Meta to a binding.
meta :: (ToBinding a) => a -> Binding
meta = addModifier Vty.MMeta

-- | Add Ctrl to a binding.
ctrl :: (ToBinding a) => a -> Binding
ctrl = addModifier Vty.MCtrl

-- | Add Shift to a binding.
shift :: (ToBinding a) => a -> Binding
shift = addModifier Vty.MShift

-- | Function key binding.
fn :: Int -> Binding
fn = bind . Vty.KFun