-- Copyright 2020 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

{-# LANGUAGE NamedFieldPuns #-}
-- | Manage the optional keycaps window.
module Cmd.SyncKeycaps (open, close, update, get_bindings) where
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Rect as Rect
import qualified Util.Lists as Lists
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.GlobalKeymap as GlobalKeymap
import qualified Cmd.KeyLayouts as KeyLayouts
import qualified Cmd.Keymap as Keymap
import qualified Cmd.NoteTrackKeymap as NoteTrackKeymap
import qualified Cmd.Perf as Perf
import qualified Cmd.PhysicalKey as PhysicalKey

import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Scale as Scale
import qualified Derive.Scale.All as Scale.All
import qualified Derive.ScoreT as ScoreT

import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Local.KeyLayout
import qualified Perform.Pitch as Pitch
import qualified Ui.Color as Color
import qualified Ui.Key as Key
import qualified Ui.Keycaps as Keycaps
import qualified Ui.KeycapsT as KeycapsT
import qualified Ui.Ui as Ui

import           Global


open :: Cmd.M m => m ()
open :: forall (m :: * -> *). M m => m ()
open = do
    KeycapsState
state <- forall (m :: * -> *). M m => m KeycapsState
keycaps_state
    Bindings
bindings <- forall (m :: * -> *). M m => KeycapsState -> m Bindings
get_bindings KeycapsState
state
    -- Put the window in the bottom right corner, to minimize conflict with
    -- ViewConfig.horizontal_tile.
    (Int
sx, Int
sy) <- Rect -> (Int, Int)
Rect.lower_right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Maybe (Int, Int) -> m Rect
Cmd.get_screen forall a. Maybe a
Nothing
    let pos :: (Int, Int)
pos = let (Int
x, Int
y) = Layout -> (Int, Int)
KeycapsT.lt_size Layout
layout in (Int
sxforall a. Num a => a -> a -> a
-Int
x, Int
syforall a. Num a => a -> a -> a
-Int
y)
    forall (m :: * -> *). M m => KeycapsUpdate -> m ()
set_update forall a b. (a -> b) -> a -> b
$ KeycapsState
-> Maybe ((Int, Int), Layout) -> RawBindings -> KeycapsUpdate
Cmd.KeycapsUpdate KeycapsState
state (forall a. a -> Maybe a
Just ((Int, Int)
pos, Layout
layout))
        (Layout -> Bindings -> RawBindings
Keycaps.resolve_bindings Layout
layout Bindings
bindings)

close :: Cmd.M m => m ()
close :: forall (m :: * -> *). M m => m ()
close = forall (m :: * -> *). M m => KeycapsUpdate -> m ()
set_update KeycapsUpdate
Cmd.KeycapsClose

update :: Cmd.M m => m ()
update :: forall (m :: * -> *). M m => m ()
update = forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> Maybe KeycapsState
Cmd.state_keycaps) forall a b. (a -> b) -> a -> b
$ \KeycapsState
old_state -> do
    KeycapsState
state <- forall (m :: * -> *). M m => m KeycapsState
keycaps_state
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeycapsState
old_state forall a. Eq a => a -> a -> Bool
/= KeycapsState
state) forall a b. (a -> b) -> a -> b
$ do
        Bindings
bindings <- forall (m :: * -> *). M m => KeycapsState -> m Bindings
get_bindings KeycapsState
state
        forall (m :: * -> *). M m => KeycapsUpdate -> m ()
set_update forall a b. (a -> b) -> a -> b
$ KeycapsState
-> Maybe ((Int, Int), Layout) -> RawBindings -> KeycapsUpdate
Cmd.KeycapsUpdate KeycapsState
state forall a. Maybe a
Nothing
            (Layout -> Bindings -> RawBindings
Keycaps.resolve_bindings Layout
layout Bindings
bindings)

set_update :: Cmd.M m => Cmd.KeycapsUpdate -> m ()
set_update :: forall (m :: * -> *). M m => KeycapsUpdate -> m ()
set_update KeycapsUpdate
kc_update = forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st ->
    State
st { state_keycaps_update :: Maybe KeycapsUpdate
Cmd.state_keycaps_update = forall a. a -> Maybe a
Just KeycapsUpdate
kc_update }

layout :: KeycapsT.Layout
layout :: Layout
layout = Map Key Rect -> Layout
Keycaps.make_layout Map Key Rect
Keycaps.mac_labels

keycaps_state :: Cmd.M m => m Cmd.KeycapsState
keycaps_state :: forall (m :: * -> *). M m => m KeycapsState
keycaps_state = do
    Set Modifier
kc_mods <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ Map Modifier Modifier -> Set Modifier
key_mods forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Modifier Modifier
Cmd.state_keys_down
    Int
kc_octave <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ EditState -> Int
Cmd.state_kbd_entry_octave forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit
    Bool
kc_is_kbd_entry <- forall (m :: * -> *). M m => m Bool
Cmd.is_kbd_entry
    -- This could fail if there is no focused block.
    (Maybe Type
kc_track_type, Maybe Instrument
kc_instrument, Maybe ScaleId
kc_scale_id) <-
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. M m => m a -> m (Maybe a)
Cmd.catch_abort forall a b. (a -> b) -> a -> b
$ do
            BlockId
block_id <- forall (m :: * -> *). M m => m BlockId
Cmd.get_focused_block
            Int
tracknum <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Int)
Cmd.get_insert_tracknum
            Maybe TrackId
mb_track_id <- forall (m :: * -> *). M m => BlockId -> Int -> m (Maybe TrackId)
Ui.event_track_at BlockId
block_id Int
tracknum
            (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Type
ParseTitle.track_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). M m => TrackId -> m Text
Ui.get_track_title)
                    Maybe TrackId
mb_track_id
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                    (\TrackId
tid -> forall (m :: * -> *). M m => Track -> m (Maybe Instrument)
Perf.lookup_instrument (BlockId
block_id, forall a. a -> Maybe a
Just TrackId
tid))
                    Maybe TrackId
mb_track_id
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => Track -> m ScaleId
Perf.get_scale_id (BlockId
block_id, Maybe TrackId
mb_track_id))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cmd.KeycapsState
        { Set Modifier
kc_mods :: Set Modifier
kc_mods :: Set Modifier
kc_mods, Int
kc_octave :: Int
kc_octave :: Int
kc_octave, Bool
kc_is_kbd_entry :: Bool
kc_is_kbd_entry :: Bool
kc_is_kbd_entry
        , Maybe Type
kc_track_type :: Maybe Type
kc_track_type :: Maybe Type
kc_track_type, Maybe Instrument
kc_instrument :: Maybe Instrument
kc_instrument :: Maybe Instrument
kc_instrument, Maybe ScaleId
kc_scale_id :: Maybe ScaleId
kc_scale_id :: Maybe ScaleId
kc_scale_id
        }

key_mods :: Map Cmd.Modifier Cmd.Modifier -> Set Cmd.Modifier
key_mods :: Map Modifier Modifier -> Set Modifier
key_mods Map Modifier Modifier
keys_down =
    forall a. Ord a => [a] -> Set a
Set.fromList [Modifier -> Modifier
Cmd.KeyMod Modifier
m | Cmd.KeyMod Modifier
m <- forall k a. Map k a -> [k]
Map.keys Map Modifier Modifier
keys_down]

-- | Get the applicable bindings for the KeycapsState.
--
-- This duplicates Cmd.Track, and the checks duplicate the checks inside
-- the underlying calls like EditUtil.fallthrough and Cmd.is_kbd_entry.  It's
-- not exactly ideal, but it seemed more practical than, say, trying to get
-- all Cmds into the Keymap mold.  The kbd_entry ones would waste a lot of
-- allocation on each cmd constructing a Map just to look up a single key.
--
-- But the duplication means that the keycaps can be inaccurate, especially the
-- exact shadowing situtaion may be incorrect.
get_bindings :: Cmd.M m => Cmd.KeycapsState -> m KeycapsT.Bindings
get_bindings :: forall (m :: * -> *). M m => KeycapsState -> m Bindings
get_bindings (Cmd.KeycapsState
        { Set Modifier
kc_mods :: Set Modifier
kc_mods :: KeycapsState -> Set Modifier
kc_mods, Int
kc_octave :: Int
kc_octave :: KeycapsState -> Int
kc_octave, Bool
kc_is_kbd_entry :: Bool
kc_is_kbd_entry :: KeycapsState -> Bool
kc_is_kbd_entry, Maybe Type
kc_track_type :: Maybe Type
kc_track_type :: KeycapsState -> Maybe Type
kc_track_type, Maybe Instrument
kc_instrument :: Maybe Instrument
kc_instrument :: KeycapsState -> Maybe Instrument
kc_instrument
        , Maybe ScaleId
kc_scale_id :: Maybe ScaleId
kc_scale_id :: KeycapsState -> Maybe ScaleId
kc_scale_id
        }) = do
    Bindings
inst_bindings <- case (Bool
kc_is_kbd_entry, Maybe Type
kc_track_type, Maybe Instrument
kc_instrument) of
        (Bool
True, Just Type
ParseTitle.NoteTrack, Just Instrument
inst)
            | Set Modifier
kc_mods forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [forall a. Monoid a => a
mempty, Set Modifier
shift] ->
                Bool -> Int -> [NoteEntryMap Binding] -> Bindings
merge_note_entry (Set Modifier
kc_mods forall a. Eq a => a -> a -> Bool
== Set Modifier
shift) Int
kc_octave forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    forall (m :: * -> *). M m => Instrument -> m [NoteEntryMap Binding]
get_instrument_bindings Instrument
inst
        (Bool, Maybe Type, Maybe Instrument)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse
        [ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty Set Modifier
kc_mods Map (Set Modifier) Bindings
global_bindings
        , case Maybe Type
kc_track_type of
            Just Type
ParseTitle.NoteTrack ->
                forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty Set Modifier
kc_mods Map (Set Modifier) Bindings
note_track_bindings
            Maybe Type
_ -> forall a. Monoid a => a
mempty
        , if Bool -> Bool
not (Bool
kc_is_kbd_entry Bool -> Bool -> Bool
&& forall a. Set a -> Bool
Set.null Set Modifier
kc_mods) then forall a. Monoid a => a
mempty
            else case Maybe Type
kc_track_type of
                Just Type
ParseTitle.PitchTrack -> Bindings
pitch_bindings
                Just Type
ParseTitle.NoteTrack -> Bindings
pitch_bindings
                Maybe Type
_ -> forall a. Monoid a => a
mempty
        , Bindings
inst_bindings
        ]
    where
    shift :: Set Modifier
shift = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ Modifier -> Modifier
Cmd.KeyMod Modifier
Key.Shift
    pitch_bindings :: Bindings
pitch_bindings = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
kc_octave
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (\ScaleId
scale_id -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScaleId
scale_id Map ScaleId (Map Int Bindings)
scale_to_bindings)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ScaleId
kc_scale_id

merge_note_entry :: Bool -> Pitch.Octave -> [Cmd.NoteEntryMap KeycapsT.Binding]
    -> KeycapsT.Bindings
merge_note_entry :: Bool -> Int -> [NoteEntryMap Binding] -> Bindings
merge_note_entry Bool
shifted Int
octave = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. NoteEntryMap a -> Map Text a
get
    where
    get :: NoteEntryMap a -> Map Text a
get = \case
        Cmd.WithOctave Map Int (Map Char a)
m -> forall {a}. Map Char a -> Map Text a
convert forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty Int
octave Map Int (Map Char a)
m
        Cmd.WithoutOctave Map Char a
m -> forall {a}. Map Char a -> Map Text a
convert Map Char a
m
    convert :: Map Char a -> Map Text a
convert = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a2 b. (a -> Maybe a2) -> [(a, b)] -> [(a2, b)]
Lists.mapMaybeFst (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
to_logical forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
char_to_keycap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Maybe Char
unshift)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
    -- Like Cmd.Keymap, I used shifted characters as a shorthand for Shift +
    -- unshifted.  This is possible since I know the exact key layout.
    unshift :: Char -> Maybe Char
unshift
        | Bool
shifted = Layout -> Char -> Maybe Char
KeyLayouts.to_unshifted Layout
Local.KeyLayout.layout
        | Bool
otherwise = forall a. a -> Maybe a
Just

char_to_keycap :: Char -> KeycapsT.Keycap
char_to_keycap :: Char -> Text
char_to_keycap = Key -> Text
Key.to_mac_label forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Key
Key.Char

-- ** instrument bindings

-- | Get bindings for the given instrument.  This isn't cached for now, but
-- it wouldn't be hard to keep a Map Instrument Bindings cache if it's slow.
get_instrument_bindings :: Cmd.M m => ScoreT.Instrument
    -> m [Cmd.NoteEntryMap KeycapsT.Binding]
get_instrument_bindings :: forall (m :: * -> *). M m => Instrument -> m [NoteEntryMap Binding]
get_instrument_bindings Instrument
inst = do
    Maybe ResolvedInstrument
resolved <- forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
Cmd.lookup_instrument Instrument
inst
    let handlers :: [HandlerId]
handlers = forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
            (InstrumentCode -> [HandlerId]
Cmd.inst_cmds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Common code -> code
Common.common_code forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Inst code -> Common code
Inst.inst_common
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Inst
Cmd.inst_instrument)
            Maybe ResolvedInstrument
resolved
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ Instrument
-> Text -> Color -> NoteEntryMap Text -> NoteEntryMap Binding
note_entry_bindings Instrument
inst (forall (m :: * -> *). NamedCmd m -> Text
Cmd.cmd_name NamedCmd CmdId
cmd) Color
Config.note_color
            NoteEntryMap Text
note_entry
        | Cmd.Handler (Just NoteEntryMap Text
note_entry) NamedCmd CmdId
cmd <- [HandlerId]
handlers
        ]

note_entry_bindings :: ScoreT.Instrument -> Text -> Color.Color
    -> Cmd.NoteEntryMap Text -> Cmd.NoteEntryMap KeycapsT.Binding
note_entry_bindings :: Instrument
-> Text -> Color -> NoteEntryMap Text -> NoteEntryMap Binding
note_entry_bindings Instrument
inst Text
source Color
color = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Binding
binding
    where
    binding :: Text -> Binding
binding Text
name
        | Text -> Bool
Text.null Text
name = Binding
KeycapsT.no_binding
        | Bool
otherwise = KeycapsT.Binding
            { b_color :: Maybe Color
b_color = forall a. a -> Maybe a
Just Color
color
            , b_text :: Text
b_text = Text
name
            , b_doc :: Text
b_doc = Text
">" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
source forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
name
            }

-- ** pitch bindings

scale_to_bindings :: Map Pitch.ScaleId (Map Pitch.Octave KeycapsT.Bindings)
scale_to_bindings :: Map ScaleId (Map Int Bindings)
scale_to_bindings = Definition -> Map Int Bindings
bindings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ScaleId Definition
Scale.All.scales
    where
    bindings :: Definition -> Map Int Bindings
bindings = \case
        Scale.Simple Scale
scale -> Scale -> Map Int Bindings
for_octaves Scale
scale
        Scale.Make ScaleId
_scale_id (Text, DocumentedCall)
_doc Environ -> LookupScale -> Either PitchError Scale
env_to_scale ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty) Scale -> Map Int Bindings
for_octaves forall a b. (a -> b) -> a -> b
$
                Environ -> LookupScale -> Either PitchError Scale
env_to_scale Environ
env LookupScale
Scale.All.lookup_scale
    for_octaves :: Scale -> Map Int Bindings
for_octaves Scale
scale =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Int
oct, Int -> Scale -> Bindings
scale_bindings Int
oct Scale
scale) | Int
oct <- [Int
0..Int
8]]
    -- This likely means Scale.Makes won't work, but I can fix that later if I
    -- want them.
    env :: Environ
env = forall a. Monoid a => a
mempty

scale_bindings :: Pitch.Octave -> Scale.Scale -> KeycapsT.Bindings
scale_bindings :: Int -> Scale -> Bindings
scale_bindings Int
octave Scale
scale =
    [(Char, Note)] -> Bindings
make_pitches forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
Either.rights forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Scale -> Environ -> Input -> Either PitchError Note
Scale.scale_input_to_note Scale
scale Environ
env)) (Int -> [(Char, Input)]
kbd_inputs Int
octave)
    where
    -- Env-sensitive notes would prevent me from caching.  Env is likely to be
    -- key and tuning, which I think should affect pitch, but not symbolic note
    -- names.
    env :: Environ
env = forall a. Monoid a => a
mempty

-- | TODO unused, but I might want it if I need env-sensitivity.
_compute_pitch_bindings :: Cmd.M m => Pitch.Octave -> m KeycapsT.Bindings
_compute_pitch_bindings :: forall (m :: * -> *). M m => Int -> m Bindings
_compute_pitch_bindings Int
octave =
    [(Char, Note)] -> Bindings
make_pitches forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) key. M m => [(key, Input)] -> m [(key, Note)]
EditUtil.inputs_to_notes (Int -> [(Char, Input)]
kbd_inputs Int
octave)

kbd_inputs :: Pitch.Octave -> [(Char, Pitch.Input)]
kbd_inputs :: Int -> [(Char, Input)]
kbd_inputs Int
octave = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Pitch -> Input
make_input) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Map Char Pitch
PhysicalKey.pitch_map
    where
    make_input :: Pitch -> Input
make_input Pitch
p = KbdType -> Pitch -> Frac -> Input
Pitch.Input KbdType
Pitch.AsciiKbd (Int -> Pitch -> Pitch
Pitch.add_octave Int
octave Pitch
p) Frac
0

make_pitches :: [(Char, Pitch.Note)] -> KeycapsT.Bindings
make_pitches :: [(Char, Note)] -> Bindings
make_pitches [(Char, Note)]
char_notes = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text -> Text
to_logical forall a b. (a -> b) -> a -> b
$ Char -> Text
char_to_keycap Char
char, Note -> Binding
binding Note
note)
    | (Char
char, Note
note) <- [(Char, Note)]
char_notes
    ]
    where
    binding :: Note -> Binding
binding Note
note = KeycapsT.Binding
        { b_color :: Maybe Color
b_color = forall a. a -> Maybe a
Just Color
Config.pitch_color
        , b_text :: Text
b_text = Note -> Text
Pitch.note_text Note
note
        , b_doc :: Text
b_doc = Text
"pitch: " forall a. Semigroup a => a -> a -> a
<> Note -> Text
Pitch.note_text Note
note
        }

-- ** global bindings

global_bindings :: Map (Set Cmd.Modifier) KeycapsT.Bindings
global_bindings :: Map (Set Modifier) Bindings
global_bindings = forall (m :: * -> *).
Maybe Color -> Keymap m -> Map (Set Modifier) Bindings
bindings_cache forall a. Maybe a
Nothing Keymap CmdId
GlobalKeymap.all_keymap

note_track_bindings :: Map (Set Cmd.Modifier) KeycapsT.Bindings
note_track_bindings :: Map (Set Modifier) Bindings
note_track_bindings =
    forall (m :: * -> *).
Maybe Color -> Keymap m -> Map (Set Modifier) Bindings
bindings_cache (forall a. a -> Maybe a
Just Color
Config.note_color) Keymap CmdId
NoteTrackKeymap.keymap

bindings_cache :: Maybe Color.Color -> Cmd.Keymap m
    -> Map (Set Cmd.Modifier) KeycapsT.Bindings
bindings_cache :: forall (m :: * -> *).
Maybe Color -> Keymap m -> Map (Set Modifier) Bindings
bindings_cache Maybe Color
mb_color Keymap m
keymap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(a, k)]
Lists.keyOnSnd Set Modifier -> Bindings
mod_bindings forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SimpleMod -> Maybe Modifier
Keymap.simple_to_mod)
    [ []
    , [SimpleMod
Keymap.Shift]
    , [SimpleMod
Keymap.PrimaryCommand]
    , [SimpleMod
Keymap.Shift, SimpleMod
Keymap.PrimaryCommand]
    , [SimpleMod
Keymap.SecondaryCommand]
    , [SimpleMod
Keymap.Shift, SimpleMod
Keymap.SecondaryCommand]
    ]
    where
    mod_bindings :: Set Modifier -> Bindings
mod_bindings Set Modifier
kmods =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Binding
binding) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Set Modifier -> Keymap m -> [(Text, Text)]
keymap_docs Set Modifier
kmods Keymap m
keymap
    binding :: Text -> Binding
binding Text
doc = KeycapsT.Binding
        { b_color :: Maybe Color
b_color = Maybe Color
mb_color
        , b_text :: Text
b_text = Text -> Text
abbreviate Text
doc
        , b_doc :: Text
b_doc = Text
doc
        }

keymap_docs :: Set Cmd.Modifier -> Cmd.Keymap m
    -> [(KeycapsT.KeyDoc, KeycapsT.Doc)]
keymap_docs :: forall (m :: * -> *). Set Modifier -> Keymap m -> [(Text, Text)]
keymap_docs Set Modifier
mods =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Text
to_logical (\(Cmd.NamedCmd Text
name Msg -> m Status
_) -> Text
name))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a2 b. (a -> Maybe a2) -> [(a, b)] -> [(a2, b)]
Lists.mapMaybeFst (Set Modifier -> KeySpec -> Maybe Text
key_spec_label Set Modifier
mods)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList

to_logical :: KeycapsT.Keycap -> KeycapsT.Keycap
to_logical :: Text -> Text
to_logical Text
label = case Text -> String
Text.unpack Text
label of
    [Char
c] | Just Char
c2 <- Layout -> Char -> Maybe Char
KeyLayouts.to_qwerty Layout
Local.KeyLayout.layout Char
c ->
        Char -> Text
Text.singleton Char
c2
    String
_ -> Text
label

-- | Make a short mnemonic that can fit in on a keycap.
abbreviate :: Text -> KeycapsT.KeyDoc
abbreviate :: Text -> Text
abbreviate =
    String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Char
symbolize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
boring)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.words
    where
    symbolize :: Text -> Char
symbolize Text
w = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (HasCallStack => Text -> Char
Text.head Text
w) Text
w Map Text Char
word_symbol
    boring :: Set Text
boring = forall a. Ord a => [a] -> Set a
Set.fromList [Text
"to", Text
"in", Text
"or", Text
"from", Text
"then"]

word_symbol :: Map Text Char
word_symbol :: Map Text Char
word_symbol = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([Text]
ks, Char
v) -> forall a b. (a -> b) -> [a] -> [b]
map (,Char
v) [Text]
ks)
    [ ([Text
"rewind", Text
"up", Text
"above"], Char
'↑')
    , ([Text
"advance", Text
"down", Text
"below"], Char
'↓')
    , ([Text
"left", Text
"previous"], Char
'←')
    , ([Text
"right", Text
"next"], Char
'→')
    , ([Text
"play"], Char
'▸')
    , ([Text
"stop"], Char
'￭')
    , ([Text
"top"], Char
'上')
    , ([Text
"bottom"], Char
'下')
    ]

key_spec_label :: Set Cmd.Modifier -> Cmd.KeySpec -> Maybe KeycapsT.Keycap
key_spec_label :: Set Modifier -> KeySpec -> Maybe Text
key_spec_label Set Modifier
mods (Cmd.KeySpec Set Modifier
smods Bindable
bindable) | Set Modifier
mods forall a. Eq a => a -> a -> Bool
== Set Modifier
smods =
    case Bindable
bindable of
        Cmd.Key Bool
_repeat Key
key -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key -> Text
Key.to_mac_label Key
key
        Bindable
_ -> forall a. Maybe a
Nothing
key_spec_label Set Modifier
_ KeySpec
_ = forall a. Maybe a
Nothing