-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Support for efficient keymaps.

    The sequence of Cmds which return Continue or Done is flexible, but
    probably inefficient in the presence of hundreds of commands.  In addition,
    it can't warn about Cmds that respond to overlapping Msgs, e.g. respond to
    the same key.

    Keymaps provide an efficient way to respond to a useful subset of Msgs,
    i.e.  those which are considered 'key down' type msgs.  The exact
    definition is in 'Bindable'.

    Keys are bound using 'SimpleMod's, which are higher level than the ones in
    "Ui.Key".  This provides allows some abstraction between they key bindings
    and which actual modifiers those imply, and allows the conflation of
    multiple modifiers.

    If you bind to a shifted key, it will be converted to Shift + unshifted by
    'KeyLayouts.to_unshifted'.  But if you want to bind to the same physical
    key with and without shift, then you should bind to the unshifted version
    and add Shift yourself.
-}
module Cmd.Keymap where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Seq as Seq
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.KeyLayouts as KeyLayouts
import qualified Cmd.Msg as Msg

import qualified Local.KeyLayout
import qualified Ui.Key as Key
import qualified Ui.Types as Types

import           Global


-- * binding

type Binding m = (Cmd.KeySpec, Cmd.NamedCmd m)

-- | Bind a Key with no modifiers.
plain_key :: Cmd.M m => Key.Key -> Text -> m () -> [Binding m]
plain_key :: forall (m :: * -> *). M m => Key -> Text -> m () -> [Binding m]
plain_key = [SimpleMod] -> Key -> Text -> m () -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Key -> Text -> m () -> [Binding m]
bind_key []

-- | Bind a Char with no modifiers.
plain_char :: Cmd.M m => Char -> Text -> m () -> [Binding m]
plain_char :: forall (m :: * -> *). M m => Char -> Text -> m () -> [Binding m]
plain_char = Key -> Text -> m () -> [Binding m]
forall (m :: * -> *). M m => Key -> Text -> m () -> [Binding m]
plain_key (Key -> Text -> m () -> [Binding m])
-> (Char -> Key) -> Char -> Text -> m () -> [Binding m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Key
Key.Char

shift_char :: Cmd.M m => Char -> Text -> m () -> [Binding m]
shift_char :: forall (m :: * -> *). M m => Char -> Text -> m () -> [Binding m]
shift_char = [SimpleMod] -> Key -> Text -> m () -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Key -> Text -> m () -> [Binding m]
bind_key [SimpleMod
Shift] (Key -> Text -> m () -> [Binding m])
-> (Char -> Key) -> Char -> Text -> m () -> [Binding m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Key
Key.Char

-- | Bind a Char with the 'PrimaryCommand'.
command_char :: Cmd.M m => Char -> Text -> m () -> [Binding m]
command_char :: forall (m :: * -> *). M m => Char -> Text -> m () -> [Binding m]
command_char = [SimpleMod] -> Key -> Text -> m () -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Key -> Text -> m () -> [Binding m]
bind_key [SimpleMod
PrimaryCommand] (Key -> Text -> m () -> [Binding m])
-> (Char -> Key) -> Char -> Text -> m () -> [Binding m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Key
Key.Char

-- | Bind a Char with the 'SecondaryCommand'.
secondary_char :: Cmd.M m => Char -> Text -> m () -> [Binding m]
secondary_char :: forall (m :: * -> *). M m => Char -> Text -> m () -> [Binding m]
secondary_char = [SimpleMod] -> Key -> Text -> m () -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Key -> Text -> m () -> [Binding m]
bind_key [SimpleMod
SecondaryCommand] (Key -> Text -> m () -> [Binding m])
-> (Char -> Key) -> Char -> Text -> m () -> [Binding m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Key
Key.Char

-- | Bind a key with the given modifiers.
bind_key :: Cmd.M m => [SimpleMod] -> Key.Key -> Text -> m () -> [Binding m]
bind_key :: forall (m :: * -> *).
M m =>
[SimpleMod] -> Key -> Text -> m () -> [Binding m]
bind_key [SimpleMod]
smods Key
key Text
desc m ()
cmd = [SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods (Bool -> Key -> Bindable
Cmd.Key Bool
False Key
key) Text
desc (m () -> Msg -> m ()
forall a b. a -> b -> a
const m ()
cmd)

-- | Bind a key with a Cmd that returns Status.
bind_key_status :: [SimpleMod] -> Key.Key -> Text -> m Cmd.Status -> [Binding m]
bind_key_status :: forall (m :: * -> *).
[SimpleMod] -> Key -> Text -> m Status -> [Binding m]
bind_key_status [SimpleMod]
smods Key
key Text
desc m Status
cmd =
    [SimpleMod] -> Bindable -> Text -> (Msg -> m Status) -> [Binding m]
forall (m :: * -> *).
[SimpleMod] -> Bindable -> Text -> (Msg -> m Status) -> [Binding m]
bind_status [SimpleMod]
smods (Bool -> Key -> Bindable
Cmd.Key Bool
False Key
key) Text
desc (m Status -> Msg -> m Status
forall a b. a -> b -> a
const m Status
cmd)

-- | Like 'bind_key', but the binding will be retriggered on key repeat.
bind_repeatable :: Cmd.M m => [SimpleMod] -> Key.Key -> Text -> m ()
    -> [Binding m]
bind_repeatable :: forall (m :: * -> *).
M m =>
[SimpleMod] -> Key -> Text -> m () -> [Binding m]
bind_repeatable [SimpleMod]
smods Key
key Text
desc m ()
cmd =
    [SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods (Bool -> Key -> Bindable
Cmd.Key Bool
True Key
key) Text
desc (m () -> Msg -> m ()
forall a b. a -> b -> a
const m ()
cmd)

-- | 'bind_click' passes the Msg to the cmd, since mouse cmds are more likely
-- to want the msg to find out where the click was.  @clicks@ is 1 for a single
-- click, 2 for a double click, etc.
bind_click :: Cmd.M m => [SimpleMod] -> Types.MouseButton -> Cmd.MouseOn -> Int
    -> Text -> (Msg.Msg -> m ()) -> [Binding m]
bind_click :: forall (m :: * -> *).
M m =>
[SimpleMod]
-> MouseButton
-> MouseOn
-> MouseButton
-> Text
-> (Msg -> m ())
-> [Binding m]
bind_click [SimpleMod]
smods MouseButton
btn MouseOn
on MouseButton
clicks Text
desc Msg -> m ()
cmd =
    [SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods (MouseButton -> MouseOn -> MouseButton -> Bindable
Cmd.Click MouseButton
btn MouseOn
on (MouseButton
clicksMouseButton -> MouseButton -> MouseButton
forall a. Num a => a -> a -> a
-MouseButton
1)) Text
desc Msg -> m ()
cmd

-- | A 'bind_drag' binds both the click and the drag.  It's conceivable to have
-- click and drag bound to different commands, but I don't have any yet.
bind_drag :: Cmd.M m => [SimpleMod] -> Types.MouseButton -> Cmd.MouseOn
    -> Text -> (Msg.Msg -> m ()) -> [Binding m]
bind_drag :: forall (m :: * -> *).
M m =>
[SimpleMod]
-> MouseButton -> MouseOn -> Text -> (Msg -> m ()) -> [Binding m]
bind_drag [SimpleMod]
smods MouseButton
btn MouseOn
on Text
desc Msg -> m ()
cmd =
    [SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods (MouseButton -> MouseOn -> MouseButton -> Bindable
Cmd.Click MouseButton
btn MouseOn
on MouseButton
0) Text
desc Msg -> m ()
cmd
    [Binding m] -> [Binding m] -> [Binding m]
forall a. [a] -> [a] -> [a]
++ [SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods (MouseButton -> MouseOn -> Bindable
Cmd.Drag MouseButton
btn MouseOn
on) Text
desc Msg -> m ()
cmd

bind_release :: Cmd.M m => [SimpleMod] -> Types.MouseButton -> Cmd.MouseOn
    -> Text -> (Msg.Msg -> m ()) -> [Binding m]
bind_release :: forall (m :: * -> *).
M m =>
[SimpleMod]
-> MouseButton -> MouseOn -> Text -> (Msg -> m ()) -> [Binding m]
bind_release [SimpleMod]
smods MouseButton
btn MouseOn
on = [SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods (MouseButton -> MouseOn -> Bindable
Cmd.Release MouseButton
btn MouseOn
on)

-- | Like 'bind_status' but the Cmd is expected to return (), which will become
-- 'Cmd.Done'.  Since the cmd has already been matched on the bound key this is
-- likely what it would have done anyway.
bind :: Cmd.M m => [SimpleMod] -> Cmd.Bindable -> Text
    -> (Msg.Msg -> m ()) -> [Binding m]
bind :: forall (m :: * -> *).
M m =>
[SimpleMod] -> Bindable -> Text -> (Msg -> m ()) -> [Binding m]
bind [SimpleMod]
smods Bindable
bindable Text
desc Msg -> m ()
cmd =
    [SimpleMod] -> Bindable -> Text -> (Msg -> m Status) -> [Binding m]
forall (m :: * -> *).
[SimpleMod] -> Bindable -> Text -> (Msg -> m Status) -> [Binding m]
bind_status [SimpleMod]
smods Bindable
bindable Text
desc ((m () -> m Status -> m Status
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done) (m () -> m Status) -> (Msg -> m ()) -> Msg -> m Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> m ()
cmd)

-- | This is the most general Binding constructor: bind any Bindable with any
-- modifiers, and don't assume the cmd returns Done.
--
-- A capital letter is shorthand for Shift + Char.toLower c.
bind_status :: [SimpleMod] -> Cmd.Bindable -> Text -> (Msg.Msg -> m Cmd.Status)
    -> [Binding m]
bind_status :: forall (m :: * -> *).
[SimpleMod] -> Bindable -> Text -> (Msg -> m Status) -> [Binding m]
bind_status [SimpleMod]
smods_ Bindable
bindable_ Text
name Msg -> m Status
cmd =
    [ ( [Modifier] -> Bindable -> KeySpec
key_spec (Bindable -> [SimpleMod] -> [Modifier]
expand_mods Bindable
bindable [SimpleMod]
smods) Bindable
bind
      , Text -> (Msg -> m Status) -> NamedCmd m
forall (m :: * -> *). Text -> (Msg -> m Status) -> NamedCmd m
Cmd.NamedCmd Text
name Msg -> m Status
cmd
      )
    | Bindable
bind <- Bindable -> [Bindable]
expand_bindable Bindable
bindable
    ]
    where
    ([SimpleMod]
smods, Bindable
bindable) = case Bindable
bindable_ of
        Cmd.Key Bool
repeat (Key.Char Char
c) ->
            case Layout -> Char -> Maybe Char
KeyLayouts.to_unshifted Layout
Local.KeyLayout.layout Char
c of
                Just Char
unshifted ->
                    -- Don't worry about a duplicate Shift, 'key_spec' makes
                    -- this a Set.
                    (SimpleMod
Shift SimpleMod -> [SimpleMod] -> [SimpleMod]
forall a. a -> [a] -> [a]
: [SimpleMod]
smods_, Bool -> Key -> Bindable
Cmd.Key Bool
repeat (Char -> Key
Key.Char Char
unshifted))
                Maybe Char
Nothing -> ([SimpleMod]
smods_, Bindable
bindable_)
        Bindable
_ -> ([SimpleMod]
smods_, Bindable
bindable_)

-- * Handler

-- | Create a Keymap for efficient lookup and return warnings encountered
-- during construction.
make_keymap :: [Binding m] -> (Cmd.Keymap m, [Text])
make_keymap :: forall (m :: * -> *). [Binding m] -> (Keymap m, [Text])
make_keymap [Binding m]
bindings = ([Binding m] -> Map KeySpec (NamedCmd m)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [Binding m]
bindings, [Text]
warns)
    where
    warns :: [Text]
warns = ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> Text
warn ([Binding m] -> [[Text]]
forall (m :: * -> *). [Binding m] -> [[Text]]
overlaps [Binding m]
bindings)
    warn :: [Text] -> Text
warn [Text]
cmds = Text
"cmds overlap, picking the last one: ["
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
cmds Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

-- ** SimpleMod

-- | The Msg contains the low level key information, but most commands should
-- probably use these higher level modifiers.  That way left and right shifts
-- work the same, and cmds can use Command as customary on the Mac and Control
-- as customary on linux.
data SimpleMod =
    Shift
    -- | Primary command key: command on Mac, control on Linux and Windows.
    -- This should be used for core and global commands.
    | PrimaryCommand
    -- | Secondary comamnd key: control or option on Mac, alt on Linux and
    -- Windows.  I'm not sure what this should be used for, but perhaps it
    -- can be for more specific event text modifications, while PrimaryCommand
    -- is for general purpose modifications.  Also, it should have
    -- non-primitive cmds, so if you override them locally you won't lose
    -- anything essential.
    | SecondaryCommand
    -- | Having mouse here allows for mouse button chording.
    | Mouse Types.MouseButton
    deriving (SimpleMod -> SimpleMod -> Bool
(SimpleMod -> SimpleMod -> Bool)
-> (SimpleMod -> SimpleMod -> Bool) -> Eq SimpleMod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleMod -> SimpleMod -> Bool
$c/= :: SimpleMod -> SimpleMod -> Bool
== :: SimpleMod -> SimpleMod -> Bool
$c== :: SimpleMod -> SimpleMod -> Bool
Eq, Eq SimpleMod
Eq SimpleMod
-> (SimpleMod -> SimpleMod -> Ordering)
-> (SimpleMod -> SimpleMod -> Bool)
-> (SimpleMod -> SimpleMod -> Bool)
-> (SimpleMod -> SimpleMod -> Bool)
-> (SimpleMod -> SimpleMod -> Bool)
-> (SimpleMod -> SimpleMod -> SimpleMod)
-> (SimpleMod -> SimpleMod -> SimpleMod)
-> Ord SimpleMod
SimpleMod -> SimpleMod -> Bool
SimpleMod -> SimpleMod -> Ordering
SimpleMod -> SimpleMod -> SimpleMod
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SimpleMod -> SimpleMod -> SimpleMod
$cmin :: SimpleMod -> SimpleMod -> SimpleMod
max :: SimpleMod -> SimpleMod -> SimpleMod
$cmax :: SimpleMod -> SimpleMod -> SimpleMod
>= :: SimpleMod -> SimpleMod -> Bool
$c>= :: SimpleMod -> SimpleMod -> Bool
> :: SimpleMod -> SimpleMod -> Bool
$c> :: SimpleMod -> SimpleMod -> Bool
<= :: SimpleMod -> SimpleMod -> Bool
$c<= :: SimpleMod -> SimpleMod -> Bool
< :: SimpleMod -> SimpleMod -> Bool
$c< :: SimpleMod -> SimpleMod -> Bool
compare :: SimpleMod -> SimpleMod -> Ordering
$ccompare :: SimpleMod -> SimpleMod -> Ordering
Ord, MouseButton -> SimpleMod -> ShowS
[SimpleMod] -> ShowS
SimpleMod -> String
(MouseButton -> SimpleMod -> ShowS)
-> (SimpleMod -> String)
-> ([SimpleMod] -> ShowS)
-> Show SimpleMod
forall a.
(MouseButton -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleMod] -> ShowS
$cshowList :: [SimpleMod] -> ShowS
show :: SimpleMod -> String
$cshow :: SimpleMod -> String
showsPrec :: MouseButton -> SimpleMod -> ShowS
$cshowsPrec :: MouseButton -> SimpleMod -> ShowS
Show)

-- | Map a SimpleMod to the Key.Modifiers it implies.
simple_mod_map :: Map SimpleMod Key.Modifier
simple_mod_map :: Map SimpleMod Modifier
simple_mod_map = [(SimpleMod, Modifier)] -> Map SimpleMod Modifier
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SimpleMod, Modifier)] -> Map SimpleMod Modifier)
-> [(SimpleMod, Modifier)] -> Map SimpleMod Modifier
forall a b. (a -> b) -> a -> b
$ case Platform
Config.platform of
    Platform
Config.Mac ->
        [ (SimpleMod
Shift, Modifier
Key.Shift)
        , (SimpleMod
PrimaryCommand, Modifier
Key.Meta)
        , (SimpleMod
SecondaryCommand, Modifier
Key.Control)
        ]
    Platform
Config.Linux ->
        [ (SimpleMod
Shift, Modifier
Key.Shift)
        , (SimpleMod
PrimaryCommand, Modifier
Key.Control)
        , (SimpleMod
SecondaryCommand, Modifier
Key.Alt)
        ]

simple_to_mod :: SimpleMod -> Maybe Cmd.Modifier
simple_to_mod :: SimpleMod -> Maybe Modifier
simple_to_mod (Mouse MouseButton
btn) = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Maybe Modifier) -> Modifier -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ MouseButton -> Maybe (MouseButton, Track) -> Modifier
Cmd.MouseMod MouseButton
btn Maybe (MouseButton, Track)
forall a. Maybe a
Nothing
simple_to_mod SimpleMod
simple = Modifier -> Modifier
Cmd.KeyMod (Modifier -> Modifier) -> Maybe Modifier -> Maybe Modifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleMod -> Map SimpleMod Modifier -> Maybe Modifier
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SimpleMod
simple Map SimpleMod Modifier
simple_mod_map

key_spec :: [Cmd.Modifier] -> Cmd.Bindable -> Cmd.KeySpec
key_spec :: [Modifier] -> Bindable -> KeySpec
key_spec [Modifier]
mods Bindable
bindable = Set Modifier -> Bindable -> KeySpec
Cmd.KeySpec ([Modifier] -> Set Modifier
forall a. Ord a => [a] -> Set a
Set.fromList [Modifier]
mods) Bindable
bindable

-- ** Bindable

overlaps :: [Binding m] -> [[Text]]
overlaps :: forall (m :: * -> *). [Binding m] -> [[Text]]
overlaps [Binding m]
bindings =
    [(Binding m -> Text) -> [Binding m] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Binding m -> Text
forall {a} {m :: * -> *}. Pretty a => (a, NamedCmd m) -> Text
cmd_name [Binding m]
grp | [Binding m]
grp <- (Binding m -> KeySpec) -> [Binding m] -> [[Binding m]]
forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Seq.group_sort Binding m -> KeySpec
forall a b. (a, b) -> a
fst [Binding m]
bindings, [Binding m] -> MouseButton
forall (t :: * -> *) a. Foldable t => t a -> MouseButton
length [Binding m]
grp MouseButton -> MouseButton -> Bool
forall a. Ord a => a -> a -> Bool
> MouseButton
1]
    where
    cmd_name :: (a, NamedCmd m) -> Text
cmd_name (a
kspec, Cmd.NamedCmd Text
name Msg -> m Status
_) =
        a -> Text
forall a. Pretty a => a -> Text
pretty a
kspec Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

-- | A binding that accepts a KeyRepeat should also accept a KeyDown.
expand_bindable :: Cmd.Bindable -> [Cmd.Bindable]
expand_bindable :: Bindable -> [Bindable]
expand_bindable (Cmd.Key Bool
True Key
key) = [Bool -> Key -> Bindable
Cmd.Key Bool
False Key
key, Bool -> Key -> Bindable
Cmd.Key Bool
True Key
key]
expand_bindable Bindable
b = [Bindable
b]

expand_mods :: Cmd.Bindable -> [SimpleMod] -> [Cmd.Modifier]
expand_mods :: Bindable -> [SimpleMod] -> [Modifier]
expand_mods Bindable
bindable [SimpleMod]
smods = (SimpleMod -> Maybe Modifier) -> [SimpleMod] -> [Modifier]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SimpleMod -> Maybe Modifier
simple_to_mod ([SimpleMod]
prefix [SimpleMod] -> [SimpleMod] -> [SimpleMod]
forall a. [a] -> [a] -> [a]
++ [SimpleMod]
smods)
    where
    -- You can't have a click or drag without having that button down!
    prefix :: [SimpleMod]
prefix = case Bindable
bindable of
        Cmd.Click MouseButton
n MouseOn
_ MouseButton
_ -> [MouseButton -> SimpleMod
Mouse MouseButton
n]
        Cmd.Drag MouseButton
n MouseOn
_ -> [MouseButton -> SimpleMod
Mouse MouseButton
n]
        Bindable
_ -> []