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

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
{- | Core CmdT monad that cmds run in.

    A Cmd is what user actions turn into.  The main thing they do is edit
    'Ui.State', or Cmd.'State', but a special subset can also do IO
    actions like saving and loading files.

    The Cmd monad has two kinds of exception: abort or throw.  Abort means
    that the Cmd decided that it's not the proper Cmd for this Msg (keystroke,
    mouse movement, whatever) and another Cmd should get a crack at it.  Throw
    means that the Cmd failed and there is nothing to be done but log an error.
    When an exception is thrown, the ui and cmd states are rolled back and midi
    output is discarded.

    Cmds should be in the monad @Cmd.M m => m ...@.

    They have to be polymorphic because they run in both IO and Identity.  IO
    because some cmds such saving and loading files require IO, and Identity
    because the majority of cmds don't.  REPL cmds run in IO so they can load
    and save, and the result is that any cmd that wants to be used from both
    Identity cmds (bound to keystrokes) and the REPL must be polymorphic in the
    monad.

    Previously I used @M@ instead of @Monad m => CmdT m ...@ to establish
    Functor, but post-AMP I don't need that any more.  But to maintain
    consistency I'll keep using @M@.
-}
module Cmd.Cmd (
    module Cmd.Cmd, Performance(..)
) where
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as Exception
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.State.Strict as MonadState
import qualified Control.Monad.Trans as Trans

import qualified Data.Hashable as Hashable
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import qualified Vivid.OSC as OSC

import qualified Util.CallStack as CallStack
import qualified Util.Exceptions as Exceptions
import qualified Util.GitT as GitT
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Logger as Logger
import qualified Util.Pretty as Pretty
import qualified Util.Ranges as Ranges
import qualified Util.Rect as Rect
import qualified Util.Texts as Texts

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Msg as Msg
import           Cmd.Msg (Performance(..))
import qualified Cmd.SaveGitT as SaveGitT
import qualified Cmd.TimeStep as TimeStep

import qualified Derive.Attrs as Attrs
import qualified Derive.Derive as Derive
import qualified Derive.Expr as Expr
import qualified Derive.Parse.Ky as Ky
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.REnv as REnv
import qualified Derive.Scale as Scale
import qualified Derive.Scale.All as Scale.All
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stack as Stack
import qualified Derive.TrackWarp as TrackWarp

import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Instrument.InstT as InstT

import qualified Midi.Interface
import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi
import qualified Midi.Mmc as Mmc
import qualified Midi.State

import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Midi.Patch as Midi.Patch
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Midi.Perform as Midi.Perform
import qualified Perform.Midi.Types as Midi.Types
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Perform.Sc.Note as Sc.Note
import qualified Perform.Sc.Patch as Sc.Patch
import qualified Perform.Transport as Transport

import qualified Synth.Shared.Config as Shared.Config
import qualified Synth.Shared.Thru as Thru
import qualified Ui.Block as Block
import qualified Ui.Color as Color
import qualified Ui.Event as Event
import qualified Ui.Key as Key
import qualified Ui.KeycapsT as KeycapsT
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Sel as Sel
import qualified Ui.Types as Types
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig
import qualified Ui.UiMsg as UiMsg
import qualified Ui.Update as Update

import           Global
import           Types


-- * Handler

-- | This is the toplevel object representing a cmd.  Fundamentally it's
-- just Msg -> Status, but it's also wrapped up in some documentation,
-- so cmds can be introspected.
data Handler m =
    Keymap !(Keymap m)
    | Handler !(Maybe (NoteEntryMap KeycapsT.KeyDoc)) !(NamedCmd m)
type HandlerId = Handler CmdId

handler :: Text -> (Msg.Msg -> m Status) -> Handler m
handler :: forall (m :: * -> *). Text -> (Msg -> m Status) -> Handler m
handler Text
name Msg -> m Status
cmd = forall (m :: * -> *).
Maybe (NoteEntryMap Text) -> NamedCmd m -> Handler m
Handler forall a. Maybe a
Nothing (forall (m :: * -> *). Text -> (Msg -> m Status) -> NamedCmd m
NamedCmd Text
name Msg -> m Status
cmd)

call :: M m => Handler m -> Msg.Msg -> m Status
call :: forall (m :: * -> *). M m => Handler m -> Msg -> m Status
call Handler m
handler = \Msg
msg ->
    let run :: NamedCmd m -> m Status
run (NamedCmd Text
n Msg -> m Status
cmd) = do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"running command: " forall a. Semigroup a => a -> a -> a
<> Text
n
            forall (m :: * -> *) a. M m => Text -> m a -> m a
name Text
n (Msg -> m Status
cmd Msg
msg)
    in case Handler m
handler of
        Handler Maybe (NoteEntryMap Text)
_ NamedCmd m
cmd -> forall {m :: * -> *}. M m => NamedCmd m -> m Status
run NamedCmd m
cmd
        Keymap Keymap m
keymap -> do
            Bindable
bindable <- forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless (Msg -> Maybe Bindable
msg_to_bindable Msg
msg)
            Set Modifier
mods <- forall (m :: * -> *). M m => m (Set Modifier)
mods_down
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue) forall {m :: * -> *}. M m => NamedCmd m -> m Status
run forall a b. (a -> b) -> a -> b
$
                forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Set Modifier -> Bindable -> KeySpec
KeySpec Set Modifier
mods Bindable
bindable) Keymap m
keymap

-- | Return the mods currently down, stripping out non-modifier keys and notes,
-- so that overlapping keys will still match.  Mouse mods are not filtered, so
-- each mouse chord can be bound individually.
mods_down :: M m => m (Set Modifier)
mods_down :: forall (m :: * -> *). M m => m (Set Modifier)
mods_down = forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter Modifier -> Bool
is_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
Map.keys) forall (m :: * -> *). M m => m (Map Modifier Modifier)
keys_down
    where
    is_mod :: Modifier -> Bool
is_mod (KeyMod {}) = Bool
True
    is_mod (MidiMod {}) = Bool
False
    is_mod (MouseMod {}) = Bool
True

-- | Pair a Cmd with a Doc that can be used for logging, undo, etc.
data NamedCmd m = NamedCmd {
    forall (m :: * -> *). NamedCmd m -> Text
cmd_name :: !Text
    , forall (m :: * -> *). NamedCmd m -> Msg -> m Status
cmd_call :: !(Msg.Msg -> m Status)
    }

-- | NoteEntry might depend on base octave, and might have different
-- mappings for unshifted or shifted.
data NoteEntryMap a =
    WithOctave (Map Pitch.Octave (Map Char a))
    | WithoutOctave (Map Char a)
    deriving (Int -> NoteEntryMap a -> ShowS
forall a. Show a => Int -> NoteEntryMap a -> ShowS
forall a. Show a => [NoteEntryMap a] -> ShowS
forall a. Show a => NoteEntryMap a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteEntryMap a] -> ShowS
$cshowList :: forall a. Show a => [NoteEntryMap a] -> ShowS
show :: NoteEntryMap a -> String
$cshow :: forall a. Show a => NoteEntryMap a -> String
showsPrec :: Int -> NoteEntryMap a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NoteEntryMap a -> ShowS
Show, forall a b. a -> NoteEntryMap b -> NoteEntryMap a
forall a b. (a -> b) -> NoteEntryMap a -> NoteEntryMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NoteEntryMap b -> NoteEntryMap a
$c<$ :: forall a b. a -> NoteEntryMap b -> NoteEntryMap a
fmap :: forall a b. (a -> b) -> NoteEntryMap a -> NoteEntryMap b
$cfmap :: forall a b. (a -> b) -> NoteEntryMap a -> NoteEntryMap b
Functor)

note_entry_lookup :: Pitch.Octave -> Char -> NoteEntryMap a -> Maybe a
note_entry_lookup :: forall a. Int -> Char -> NoteEntryMap a -> Maybe a
note_entry_lookup Int
octave Char
char = \case
    WithOctave Map Int (Map Char a)
m -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
char forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
octave Map Int (Map Char a)
m
    WithoutOctave Map Char a
m -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
char Map Char a
m

-- ** Keymap

type Keymap m = Map KeySpec (NamedCmd m)

data KeySpec = KeySpec !(Set Modifier) !Bindable
    deriving (KeySpec -> KeySpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeySpec -> KeySpec -> Bool
$c/= :: KeySpec -> KeySpec -> Bool
== :: KeySpec -> KeySpec -> Bool
$c== :: KeySpec -> KeySpec -> Bool
Eq, Eq KeySpec
KeySpec -> KeySpec -> Bool
KeySpec -> KeySpec -> Ordering
KeySpec -> KeySpec -> KeySpec
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 :: KeySpec -> KeySpec -> KeySpec
$cmin :: KeySpec -> KeySpec -> KeySpec
max :: KeySpec -> KeySpec -> KeySpec
$cmax :: KeySpec -> KeySpec -> KeySpec
>= :: KeySpec -> KeySpec -> Bool
$c>= :: KeySpec -> KeySpec -> Bool
> :: KeySpec -> KeySpec -> Bool
$c> :: KeySpec -> KeySpec -> Bool
<= :: KeySpec -> KeySpec -> Bool
$c<= :: KeySpec -> KeySpec -> Bool
< :: KeySpec -> KeySpec -> Bool
$c< :: KeySpec -> KeySpec -> Bool
compare :: KeySpec -> KeySpec -> Ordering
$ccompare :: KeySpec -> KeySpec -> Ordering
Ord, Int -> KeySpec -> ShowS
[KeySpec] -> ShowS
KeySpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeySpec] -> ShowS
$cshowList :: [KeySpec] -> ShowS
show :: KeySpec -> String
$cshow :: KeySpec -> String
showsPrec :: Int -> KeySpec -> ShowS
$cshowsPrec :: Int -> KeySpec -> ShowS
Show)

data Bindable =
    -- | Key IsRepeat Key
    Key Bool Key.Key
    -- | Click MouseButton Clicks
    | Click Types.MouseButton MouseOn Int
    | Drag Types.MouseButton MouseOn
    -- | Mouse button release.
    | Release Types.MouseButton MouseOn
    -- | Channel can be used to restrict bindings to a certain keyboard.  This
    -- should probably be something more abstract though, such as a device
    -- which can be set by the static config.
    | Note Midi.Channel Midi.Key
    deriving (Bindable -> Bindable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bindable -> Bindable -> Bool
$c/= :: Bindable -> Bindable -> Bool
== :: Bindable -> Bindable -> Bool
$c== :: Bindable -> Bindable -> Bool
Eq, Eq Bindable
Bindable -> Bindable -> Bool
Bindable -> Bindable -> Ordering
Bindable -> Bindable -> Bindable
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 :: Bindable -> Bindable -> Bindable
$cmin :: Bindable -> Bindable -> Bindable
max :: Bindable -> Bindable -> Bindable
$cmax :: Bindable -> Bindable -> Bindable
>= :: Bindable -> Bindable -> Bool
$c>= :: Bindable -> Bindable -> Bool
> :: Bindable -> Bindable -> Bool
$c> :: Bindable -> Bindable -> Bool
<= :: Bindable -> Bindable -> Bool
$c<= :: Bindable -> Bindable -> Bool
< :: Bindable -> Bindable -> Bool
$c< :: Bindable -> Bindable -> Bool
compare :: Bindable -> Bindable -> Ordering
$ccompare :: Bindable -> Bindable -> Ordering
Ord, Int -> Bindable -> ShowS
[Bindable] -> ShowS
Bindable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bindable] -> ShowS
$cshowList :: [Bindable] -> ShowS
show :: Bindable -> String
$cshow :: Bindable -> String
showsPrec :: Int -> Bindable -> ShowS
$cshowsPrec :: Int -> Bindable -> ShowS
Show)

-- | Where a click or drag occurred.
data MouseOn = OnTrack | OnDivider | OnSkeleton | Elsewhere
    deriving (MouseOn -> MouseOn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MouseOn -> MouseOn -> Bool
$c/= :: MouseOn -> MouseOn -> Bool
== :: MouseOn -> MouseOn -> Bool
$c== :: MouseOn -> MouseOn -> Bool
Eq, Eq MouseOn
MouseOn -> MouseOn -> Bool
MouseOn -> MouseOn -> Ordering
MouseOn -> MouseOn -> MouseOn
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 :: MouseOn -> MouseOn -> MouseOn
$cmin :: MouseOn -> MouseOn -> MouseOn
max :: MouseOn -> MouseOn -> MouseOn
$cmax :: MouseOn -> MouseOn -> MouseOn
>= :: MouseOn -> MouseOn -> Bool
$c>= :: MouseOn -> MouseOn -> Bool
> :: MouseOn -> MouseOn -> Bool
$c> :: MouseOn -> MouseOn -> Bool
<= :: MouseOn -> MouseOn -> Bool
$c<= :: MouseOn -> MouseOn -> Bool
< :: MouseOn -> MouseOn -> Bool
$c< :: MouseOn -> MouseOn -> Bool
compare :: MouseOn -> MouseOn -> Ordering
$ccompare :: MouseOn -> MouseOn -> Ordering
Ord, Int -> MouseOn -> ShowS
[MouseOn] -> ShowS
MouseOn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MouseOn] -> ShowS
$cshowList :: [MouseOn] -> ShowS
show :: MouseOn -> String
$cshow :: MouseOn -> String
showsPrec :: Int -> MouseOn -> ShowS
$cshowsPrec :: Int -> MouseOn -> ShowS
Show)

msg_to_bindable :: Msg.Msg -> Maybe Bindable
msg_to_bindable :: Msg -> Maybe Bindable
msg_to_bindable Msg
msg = case Msg
msg of
    (Msg -> Maybe (Bool, Key)
get_key -> Just (Bool
is_repeat, Key
key)) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> Key -> Bindable
Key Bool
is_repeat Key
key
    (Msg -> Maybe MouseEvent
Msg.mouse -> Just MouseEvent
mouse) -> case MouseEvent -> MouseState
UiMsg.mouse_state MouseEvent
mouse of
        UiMsg.MouseDown Int
btn ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> MouseOn -> Int -> Bindable
Click Int
btn MouseOn
on (MouseEvent -> Int
UiMsg.mouse_clicks MouseEvent
mouse)
        UiMsg.MouseDrag Int
btn -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> MouseOn -> Bindable
Drag Int
btn MouseOn
on
        UiMsg.MouseUp Int
btn -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> MouseOn -> Bindable
Release Int
btn MouseOn
on
        MouseState
_ -> forall a. Maybe a
Nothing
    (Msg -> Maybe Message
Msg.midi -> Just (Midi.ChannelMessage Channel
chan (Midi.NoteOn Key
key Channel
_))) ->
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Channel -> Key -> Bindable
Note Channel
chan Key
key
    Msg
_ -> forall a. Maybe a
Nothing
    where
    on :: MouseOn
on = forall b a. b -> (a -> b) -> Maybe a -> b
maybe MouseOn
Elsewhere Context -> MouseOn
mouse_on (Msg -> Maybe Context
Msg.context Msg
msg)
    get_key :: Msg -> Maybe (Bool, Key)
get_key Msg
msg = case Msg -> Maybe (KbdState, Key)
Msg.key Msg
msg of
        Just (KbdState
UiMsg.KeyDown, Key
k) -> forall a. a -> Maybe a
Just (Bool
False, Key
k)
        Just (KbdState
UiMsg.KeyRepeat, Key
k) -> forall a. a -> Maybe a
Just (Bool
True, Key
k)
        Maybe (KbdState, Key)
_ -> forall a. Maybe a
Nothing

mouse_on :: UiMsg.Context -> MouseOn
mouse_on :: Context -> MouseOn
mouse_on = forall b a. b -> (a -> b) -> Maybe a -> b
maybe MouseOn
Elsewhere forall {a}. (a, Track) -> MouseOn
on forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Maybe (Int, Track)
UiMsg.ctx_track
    where
    on :: (a, Track) -> MouseOn
on (a
_, UiMsg.Track {}) = MouseOn
OnTrack
    on (a
_, Track
UiMsg.Divider) = MouseOn
OnDivider
    on (a
_, Track
UiMsg.SkeletonDisplay) = MouseOn
OnSkeleton

-- ** pretty instances

instance Pretty (Handler m) where
    format :: Handler m -> Doc
format = \case
        Handler Maybe (NoteEntryMap Text)
_ NamedCmd m
cmd -> forall a. Pretty a => a -> Doc
Pretty.format NamedCmd m
cmd
        Keymap Keymap m
keymap -> forall a. Pretty a => a -> Doc
Pretty.format Keymap m
keymap

instance Pretty (NamedCmd m) where
    pretty :: NamedCmd m -> Text
pretty (NamedCmd Text
name Msg -> m Status
_) = Text
"cmd:" forall a. Semigroup a => a -> a -> a
<> Text
name

instance Pretty KeySpec where
    pretty :: KeySpec -> Text
pretty (KeySpec Set Modifier
mods Bindable
bindable) =
        forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
" " (Set Modifier -> Text
show_mods Set Modifier
mods) (Bool -> Bindable -> Text
show_bindable Bool
True Bindable
bindable)
        where show_mods :: Set Modifier -> Text
show_mods = Text -> [Text] -> Text
Text.intercalate Text
" + " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Modifier -> Text
show_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList

show_mod :: Modifier -> Text
show_mod :: Modifier -> Text
show_mod Modifier
m = case Modifier
m of
    -- TODO this is only true on OS X
    KeyMod Modifier
mod -> Modifier -> Text
Key.show_mac_mod Modifier
mod
    MouseMod Int
button Maybe (Int, Track)
_ -> Text
"mouse " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
button
    MidiMod Channel
chan Key
key -> Text
"midi " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Key
key forall a. Semigroup a => a -> a -> a
<> Text
" chan " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Channel
chan

instance Pretty Bindable where
    pretty :: Bindable -> Text
pretty = Bool -> Bindable -> Text
show_bindable Bool
True

show_bindable :: Bool -> Bindable -> Text
show_bindable :: Bool -> Bindable -> Text
show_bindable Bool
show_repeatable Bindable
b = case Bindable
b of
    Key Bool
is_repeat Key
key -> forall a. Pretty a => a -> Text
pretty Key
key
        forall a. Semigroup a => a -> a -> a
<> if Bool
show_repeatable Bool -> Bool -> Bool
&& Bool
is_repeat then Text
" (repeatable)" else Text
""
    Click Int
button MouseOn
on Int
times -> forall {a}. (Eq a, Num a, Show a) => a -> Text
click_times Int
times forall a. Semigroup a => a -> a -> a
<> Text
"click "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
button forall a. Semigroup a => a -> a -> a
<> Text
" on " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty MouseOn
on
    Drag Int
button MouseOn
on -> Text
"drag " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
button forall a. Semigroup a => a -> a -> a
<> Text
" on " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty MouseOn
on
    Release Int
button MouseOn
on -> Text
"release " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
button forall a. Semigroup a => a -> a -> a
<> Text
" on " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty MouseOn
on
    Note Channel
chan Key
key -> Text
"midi " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Key
key forall a. Semigroup a => a -> a -> a
<> Text
" channel " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Channel
chan
    where
    click_times :: a -> Text
click_times a
0 = Text
""
    click_times a
1 = Text
"double-"
    click_times a
2 = Text
"triple-"
    click_times a
n = forall a. Show a => a -> Text
showt a
n forall a. Semigroup a => a -> a -> a
<> Text
"-"

instance Pretty MouseOn where
    pretty :: MouseOn -> Text
pretty MouseOn
OnTrack = Text
"track"
    pretty MouseOn
OnDivider = Text
"divider"
    pretty MouseOn
OnSkeleton = Text
"skeleton"
    pretty MouseOn
Elsewhere = Text
"elsewhere"


-- * run CmdT

type CmdId = CmdT Identity.Identity

-- | Cmds used by the REPL, which all run in IO.
type CmdL a = CmdT IO a

data Status =
    -- | Continue processing, so another Cmd will have an opportunity to see
    -- the Msg.
    Continue
    -- | Stop further cmd processing, \"consuming\" the Msg.
    | Done
    -- | Hack to control import dependencies, see "Cmd.PlayC".
    | Play !PlayArgs
    -- | Open a FloatingInput box.
    | FloatingInput !FloatingInput
    -- | Pack it up and go home.
    | Quit
    deriving (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show)

-- | Combine two Statuses by keeping the one with higher priority.
-- Yes, Status could be a Monoid but merge should be a rare operation.
merge_status :: Status -> Status -> Status
merge_status :: Status -> Status -> Status
merge_status Status
s1 Status
s2 = if forall {a}. Num a => Status -> a
prio Status
s1 forall a. Ord a => a -> a -> Bool
>= forall {a}. Num a => Status -> a
prio Status
s2 then Status
s1 else Status
s2
    where
    prio :: Status -> a
prio Status
status = case Status
status of
        Status
Continue -> a
0
        Status
Done -> a
1
        Play {} -> a
2
        FloatingInput {} -> a
3
        Status
Quit -> a
4

-- | Arguments for 'Cmd.PlayC.play'.  This is a special return value to trigger
-- a play, see "Cmd.PlayC" for details.
data PlayArgs = PlayArgs {
    PlayArgs -> Maybe SyncConfig
play_sync :: !(Maybe SyncConfig)
    -- | Description of what is being played for logging.
    , PlayArgs -> Text
play_name :: !Text
    , PlayArgs -> MidiEvents
play_midi :: !Midi.Perform.MidiEvents
    , PlayArgs -> PlayNotes
play_sc :: !Sc.Note.PlayNotes
    , PlayArgs -> Maybe InverseTempoFunction
play_inv_tempo :: !(Maybe Transport.InverseTempoFunction)
    , PlayArgs -> Maybe RealTime
play_repeat_at :: !(Maybe RealTime)
    -- | Since im playback is done by the VST, I don't directly control it as I
    -- do with the MIDI player, effectively all the sound is "in the decay." So
    -- I have an explicit end, and the MIDI thread will pretend it's still
    -- playing until it crosses this boundary.
    , PlayArgs -> Maybe RealTime
play_im_end :: !(Maybe RealTime)
    , PlayArgs -> Maybe PlayDirectArgs
play_im_direct :: !(Maybe PlayDirectArgs)
    }
instance Show PlayArgs where show :: PlayArgs -> String
show PlayArgs
_ = String
"((PlayArgs))"

-- | Arguments for 'Cmd.PlayC.play_im_direct_thread'.
data PlayDirectArgs = PlayDirectArgs {
    PlayDirectArgs -> String
play_score_path :: FilePath
    , PlayDirectArgs -> BlockId
play_block_id :: BlockId
    , PlayDirectArgs -> Set Instrument
play_muted :: Set ScoreT.Instrument
    , PlayDirectArgs -> RealTime
play_start :: RealTime
    } deriving (PlayDirectArgs -> PlayDirectArgs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayDirectArgs -> PlayDirectArgs -> Bool
$c/= :: PlayDirectArgs -> PlayDirectArgs -> Bool
== :: PlayDirectArgs -> PlayDirectArgs -> Bool
$c== :: PlayDirectArgs -> PlayDirectArgs -> Bool
Eq, Int -> PlayDirectArgs -> ShowS
[PlayDirectArgs] -> ShowS
PlayDirectArgs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayDirectArgs] -> ShowS
$cshowList :: [PlayDirectArgs] -> ShowS
show :: PlayDirectArgs -> String
$cshow :: PlayDirectArgs -> String
showsPrec :: Int -> PlayDirectArgs -> ShowS
$cshowsPrec :: Int -> PlayDirectArgs -> ShowS
Show)

data FloatingInput =
    -- | Open a new floating text input.
    -- View, track, pos, (select start, select end).
    FloatingOpen !ViewId !TrackNum !ScoreTime !Text !(Int, Int)
    -- | Insert the given text into an already open edit box.
    | FloatingInsert !Text
    deriving (Int -> FloatingInput -> ShowS
[FloatingInput] -> ShowS
FloatingInput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FloatingInput] -> ShowS
$cshowList :: [FloatingInput] -> ShowS
show :: FloatingInput -> String
$cshow :: FloatingInput -> String
showsPrec :: Int -> FloatingInput -> ShowS
$cshowsPrec :: Int -> FloatingInput -> ShowS
Show)

-- | Cmds can run in either Identity or IO, but are generally returned in IO,
-- just to make things uniform.
type RunCmd cmd_m val_m a =
    Ui.State -> State -> CmdT cmd_m a -> val_m (Result a)

-- | The result of running a Cmd.
type Result a =
    ( State
    , [Thru]
    , [Log.Msg]
    , Either Ui.Error (a, Ui.State, Update.UiDamage)
    )

run :: Monad m => a -> RunCmd m m a
run :: forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run a
abort_val State
ustate State
cstate CmdT m a
cmd = do
    (((Either Error (a, State, UiDamage)
ui_result, State
cstate2), [Thru]
midi), [Msg]
logs) <-
        (forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg])
Log.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
Logger.run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
MonadState.runStateT State
cstate
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Monad m =>
State -> StateT m a -> m (Either Error (a, State, UiDamage))
Ui.run State
ustate forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(CmdT StateT (StateT State (LoggerT Thru (LogT m))) a
m) -> StateT (StateT State (LoggerT Thru (LogT m))) a
m))
        CmdT m a
cmd
    -- Any kind of error rolls back state and discards midi, but not log msgs.
    -- Normally 'abort_val' will be Continue, but obviously if 'cmd' doesn't
    -- return Status it can't be.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Error (a, State, UiDamage)
ui_result of
        Left Error
Ui.Abort -> (State
cstate, [], [Msg]
logs, forall a b. b -> Either a b
Right (a
abort_val, State
ustate, forall a. Monoid a => a
mempty))
        Left Error
_ -> (State
cstate, [], [Msg]
logs, Either Error (a, State, UiDamage)
ui_result)
        Either Error (a, State, UiDamage)
_ -> (State
cstate2, [Thru]
midi, [Msg]
logs, Either Error (a, State, UiDamage)
ui_result)

-- | Like 'run', but discard MIDI thru and updates.
run_ :: Monad m => Ui.State -> State -> CmdT m a
    -> m (Either String (a, State, Ui.State), [Log.Msg])
run_ :: forall (m :: * -> *) a.
Monad m =>
State
-> State -> CmdT m a -> m (Either String (a, State, State), [Msg])
run_ State
ui_state State
cmd_state CmdT m a
cmd = do
    (State
cmd_state, [Thru]
_thru, [Msg]
logs, Either Error (Maybe a, State, UiDamage)
result) <-
        forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run forall a. Maybe a
Nothing State
ui_state State
cmd_state (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just CmdT m a
cmd)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (, [Msg]
logs) forall a b. (a -> b) -> a -> b
$ case Either Error (Maybe a, State, UiDamage)
result of
        Left Error
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
prettys Error
err
        Right (Maybe a
val, State
ui_state, UiDamage
_damage) -> case Maybe a
val of
            Maybe a
Nothing -> forall a b. a -> Either a b
Left String
"aborted"
            Just a
v -> forall a b. b -> Either a b
Right (a
v, State
cmd_state, State
ui_state)

-- | Like 'run_', but discard all the final states.
eval :: Monad m => Ui.State -> State -> CmdT m a
    -> m (Either String a, [Log.Msg])
eval :: forall (m :: * -> *) a.
Monad m =>
State -> State -> CmdT m a -> m (Either String a, [Msg])
eval State
ui_state State
cmd_state = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall {a} {b} {c}. (a, b, c) -> a
val_of)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Monad m =>
State
-> State -> CmdT m a -> m (Either String (a, State, State), [Msg])
run_ State
ui_state State
cmd_state
    where
    val_of :: (a, b, c) -> a
val_of (a
a, b
_, c
_) = a
a

-- | Run the Cmd in Identity, returning Nothing if it aborted.
run_id :: Ui.State -> State -> CmdT Identity.Identity a -> Result (Maybe a)
run_id :: forall a. State -> State -> CmdT Identity a -> Result (Maybe a)
run_id State
ui_state State
cmd_state CmdT Identity a
cmd =
    forall a. Identity a -> a
Identity.runIdentity (forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run forall a. Maybe a
Nothing State
ui_state State
cmd_state (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just CmdT Identity a
cmd))

-- | Run the given command in Identity, but return it in IO, just as
-- a convenient way to have a uniform return type with 'run' (provided it is
-- run in IO).
run_id_io :: RunCmd Identity.Identity IO Status
run_id_io :: RunCmd Identity IO Status
run_id_io State
ui_state State
cmd_state CmdT Identity Status
cmd =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
Identity.runIdentity (forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run Status
Continue State
ui_state State
cmd_state CmdT Identity Status
cmd)

run_io :: RunCmd IO IO Status
run_io :: RunCmd IO IO Status
run_io = forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run Status
Continue

-- | Promote a CmdId to a generic cmd, which can also run as a CmdT IO.
-- TODO: shouldn't it be possible to do this for free?
lift_id :: M m => CmdId a -> m a
lift_id :: forall (m :: * -> *) a. M m => CmdId a -> m a
lift_id CmdId a
cmd = do
    (State
cmd_state, [Thru]
thru, [Msg]
logs, Either Error (Maybe a, State, UiDamage)
result) <- forall a. State -> State -> CmdT Identity a -> Result (Maybe a)
run_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m State
Ui.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). M m => m State
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure CmdId a
cmd
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    case Either Error (Maybe a, State, UiDamage)
result of
        Left Error
err -> forall (m :: * -> *) a. M m => Error -> m a
Ui.throw_error Error
err
        Right (Maybe a
val, State
ui_state, UiDamage
damage) -> case Maybe a
val of
            Maybe a
Nothing -> forall (m :: * -> *) a. M m => m a
abort
            Just a
val -> do
                forall (m :: * -> *). M m => State -> m ()
put State
cmd_state
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Thru -> m ()
write_thru [Thru]
thru
                forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage UiDamage
damage
                forall (m :: * -> *). M m => State -> m ()
Ui.unsafe_put State
ui_state
                forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Run a set of Cmds as a single Cmd.  The first one to return non-Continue
-- will return.  Cmds can use this to dispatch to other Cmds.
sequence_cmds :: M m => [a -> m Status] -> a -> m Status
sequence_cmds :: forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
sequence_cmds [] a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue
sequence_cmds (a -> m Status
cmd:[a -> m Status]
cmds) a
msg = do
    Maybe Status
status <- forall (m :: * -> *) a. M m => m a -> m (Maybe a)
catch_abort (a -> m Status
cmd a
msg)
    case Maybe Status
status of
        Maybe Status
Nothing -> forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
sequence_cmds [a -> m Status]
cmds a
msg
        Just Status
Continue -> forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
sequence_cmds [a -> m Status]
cmds a
msg
        Just Status
status -> forall (m :: * -> *) a. Monad m => a -> m a
return Status
status

-- * CmdT and operations

type CmdStack m = Ui.StateT
    (MonadState.StateT State
        (Logger.LoggerT Thru
            (Log.LogT m)))

newtype CmdT m a = CmdT (CmdStack m a)
    deriving (forall a b. a -> CmdT m b -> CmdT m a
forall a b. (a -> b) -> CmdT m a -> CmdT m b
forall (m :: * -> *) a b. Functor m => a -> CmdT m b -> CmdT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CmdT m a -> CmdT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CmdT m b -> CmdT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> CmdT m b -> CmdT m a
fmap :: forall a b. (a -> b) -> CmdT m a -> CmdT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> CmdT m a -> CmdT m b
Functor, forall a. a -> CmdT m a
forall a b. CmdT m a -> CmdT m b -> CmdT m b
forall a b. CmdT m a -> (a -> CmdT m b) -> CmdT m b
forall {m :: * -> *}. Monad m => Applicative (CmdT m)
forall (m :: * -> *) a. Monad m => a -> CmdT m a
forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> CmdT m b -> CmdT m b
forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> (a -> CmdT m b) -> CmdT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> CmdT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> CmdT m a
>> :: forall a b. CmdT m a -> CmdT m b -> CmdT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> CmdT m b -> CmdT m b
>>= :: forall a b. CmdT m a -> (a -> CmdT m b) -> CmdT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> (a -> CmdT m b) -> CmdT m b
Monad, forall a. IO a -> CmdT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (CmdT m)
forall (m :: * -> *) a. MonadIO m => IO a -> CmdT m a
liftIO :: forall a. IO a -> CmdT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> CmdT m a
MonadIO, Except.MonadError Ui.Error, forall a. a -> CmdT m a
forall a b. CmdT m a -> CmdT m b -> CmdT m a
forall a b. CmdT m a -> CmdT m b -> CmdT m b
forall a b. CmdT m (a -> b) -> CmdT m a -> CmdT m b
forall a b c. (a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c
forall {m :: * -> *}. Monad m => Functor (CmdT m)
forall (m :: * -> *) a. Monad m => a -> CmdT m a
forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> CmdT m b -> CmdT m a
forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> CmdT m b -> CmdT m b
forall (m :: * -> *) a b.
Monad m =>
CmdT m (a -> b) -> CmdT m a -> CmdT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. CmdT m a -> CmdT m b -> CmdT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> CmdT m b -> CmdT m a
*> :: forall a b. CmdT m a -> CmdT m b -> CmdT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
CmdT m a -> CmdT m b -> CmdT m b
liftA2 :: forall a b c. (a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c
<*> :: forall a b. CmdT m (a -> b) -> CmdT m a -> CmdT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
CmdT m (a -> b) -> CmdT m a -> CmdT m b
pure :: forall a. a -> CmdT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> CmdT m a
Applicative)

class (Log.LogMonad m, Ui.M m) => M m where
    -- Not in MonadState for the same reasons as 'Ui.Ui.M'.
    get :: m State
    put :: State -> m ()
    -- | Log a note to send out.  This is the midi or im thru mechanism.
    write_thru :: Thru -> m ()
    -- | An abort is an exception to get out of CmdT, but it's considered the
    -- same as returning Continue.  It's so a command can back out if e.g. it's
    -- selected by the 'Keymap' but has an additional prerequisite such as
    -- having an active block.
    abort :: m a
    catch_abort :: m a -> m (Maybe a)

instance Monad m => M (CmdT m) where
    get :: CmdT m State
get = (forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) forall s (m :: * -> *). MonadState s m => m s
MonadState.get
    put :: State -> CmdT m ()
put State
st = (forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (forall s (m :: * -> *). MonadState s m => s -> m ()
MonadState.put State
st)
    write_thru :: Thru -> CmdT m ()
write_thru Thru
msg = (forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log Thru
msg)
    abort :: forall a. CmdT m a
abort = forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Error
Ui.Abort
    catch_abort :: forall a. CmdT m a -> CmdT m (Maybe a)
catch_abort CmdT m a
m = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just CmdT m a
m) forall {m :: * -> *} {a}.
MonadError Error m =>
Error -> m (Maybe a)
catch
        where
        catch :: Error -> m (Maybe a)
catch Error
Ui.Abort = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        catch Error
err = forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Error
err

data Thru =
    -- | Send MIDI thru.  You can give it a timestamp, but it should be 0 for
    -- thru, which will cause it to go straight to the front of the queue.  Use
    -- 'midi' for normal midi thru.
    MidiThru !Midi.Interface.Message
    | ImThru !Thru.Message
    | OscThru ![OSC.OSC]
    deriving (Int -> Thru -> ShowS
[Thru] -> ShowS
Thru -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Thru] -> ShowS
$cshowList :: [Thru] -> ShowS
show :: Thru -> String
$cshow :: Thru -> String
showsPrec :: Int -> Thru -> ShowS
$cshowsPrec :: Int -> Thru -> ShowS
Show)

midi_thru :: Midi.WriteDevice -> Midi.Message -> Thru
midi_thru :: WriteDevice -> Message -> Thru
midi_thru WriteDevice
dev Message
msg =
    Message -> Thru
MidiThru forall a b. (a -> b) -> a -> b
$ WriteMessage -> Message
Midi.Interface.Midi forall a b. (a -> b) -> a -> b
$ WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
0 Message
msg

midi :: M m => Midi.WriteDevice -> Midi.Message -> m ()
midi :: forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
midi WriteDevice
dev Message
msg = forall (m :: * -> *). M m => Thru -> m ()
write_thru forall a b. (a -> b) -> a -> b
$ WriteDevice -> Message -> Thru
midi_thru WriteDevice
dev Message
msg

osc :: M m => [OSC.OSC] -> m ()
osc :: forall (m :: * -> *). M m => [OSC] -> m ()
osc = forall (m :: * -> *). M m => Thru -> m ()
write_thru forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OSC] -> Thru
OscThru

-- | For some reason, newtype deriving doesn't work on MonadTrans.
instance Trans.MonadTrans CmdT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> CmdT m a
lift = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift -- whee!!

-- | Give CmdT unlifted access to all the logging functions.
instance Monad m => Log.LogMonad (CmdT m) where
    write :: Msg -> CmdT m ()
write = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write

-- | And to the UI state operations.
instance Monad m => Ui.M (CmdT m) where
    get :: CmdT m State
get = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall (m :: * -> *). M m => m State
Ui.get
    unsafe_put :: State -> CmdT m ()
unsafe_put State
st = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (forall (m :: * -> *). M m => State -> m ()
Ui.unsafe_put State
st)
    damage :: UiDamage -> CmdT m ()
damage UiDamage
upd = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage UiDamage
upd)
    get_damage :: CmdT m UiDamage
get_damage = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT forall (m :: * -> *). M m => m UiDamage
Ui.get_damage
    throw_error :: forall a. Error -> CmdT m a
throw_error Error
msg = forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (forall (m :: * -> *) a. M m => Error -> m a
Ui.throw_error Error
msg)

-- ** exceptions

-- | This is the same as Ui.throw, but it feels like things in Cmd may not
-- always want to reuse State's exceptions, so they should call this one.
throw :: (CallStack.Stack, M m) => Text -> m a
throw :: forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw = forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw

-- | Run a subcomputation that is allowed to abort.
ignore_abort :: M m => m a -> m ()
ignore_abort :: forall (m :: * -> *) a. M m => m a -> m ()
ignore_abort m a
m = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. M m => m a -> m (Maybe a)
catch_abort m a
m

-- | Run an IO action, rethrowing any IO exception as a Cmd exception.
rethrow_io :: IO a -> CmdT IO a
rethrow_io :: forall a. IO a -> CmdT IO a
rethrow_io =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle forall a. SomeException -> IO (Either Text a)
handle forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. b -> Either a b
Right <$>)
    where
    handle :: Exception.SomeException -> IO (Either Text a)
    handle :: forall a. SomeException -> IO (Either Text a)
handle = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"io exception: "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt

-- | Extract a Just value, or 'abort'.  Generally used to check for Cmd
-- conditions that don't fit into a Keymap.
abort_unless :: M m => Maybe a -> m a
abort_unless :: forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. M m => m a
abort forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Throw an exception with the given msg on Nothing.
require :: (CallStack.Stack, M m) => Text -> Maybe a -> m a
require :: forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require Text
msg = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
msg) forall (m :: * -> *) a. Monad m => a -> m a
return

require_right :: (CallStack.Stack, M m) => (err -> Text) -> Either err a -> m a
require_right :: forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
require_right err -> Text
fmt_err = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) forall (m :: * -> *) a. Monad m => a -> m a
return

-- * State

{- | App global state.  Unlike 'Ui.State', this is not saved to disk.
    This is normally modified inside a 'CmdT', which is also a 'State.StateT',
    so it can also use the UI state functions.  If an exception is thrown, both
    this state and the UI state will be rolled back.

    This is kind of an unorganized wodge.  The problem is that since state is
    all centralized in one place, every special snowflake Cmd that needs its
    own bit of state winds up getting its own little knob in here.  On one
    hand, it's non-modular.  On the other hand, it lets me keep an eye on it.

    So far, most Cmds are pretty fundamental, so they more or less deserve
    their spots here.  If it gets out of control, though, I'll have to either
    come up with a clever way of storing typed data where they can't collide,
    say by having a Cmd return a new Cmd and keeping the state trapped inside,
    or a less clever but simpler and easier way like @Map Name Dynamic@.
-}
data State = State {
    State -> Config
state_config :: !Config
    -- | If set, the current 'Ui.State' was loaded from this file.
    -- This is so save can keep saving to the same file.
    , State -> Maybe (Writable, SaveFile)
state_save_file :: !(Maybe (Writable, SaveFile))
    , State -> Saved
state_saved :: !Saved
    , State -> Maybe KyCache
state_ky_cache :: !(Maybe KyCache)
    -- | Omit the usual derive delay for these blocks, and trigger a derive.
    -- This is set by integration, which modifies a block in response to
    -- another block being derived.  Blocks set to derive immediately are also
    -- considered to have block damage, if they didn't already.  This is
    -- cleared after every cmd.
    , State -> Set BlockId
state_derive_immediately :: !(Set BlockId)
    -- | History.
    , State -> History
state_history :: !History
    , State -> HistoryConfig
state_history_config :: !HistoryConfig
    , State -> HistoryCollect
state_history_collect :: !HistoryCollect
    , State -> SelectionHistory
state_selection_history :: !SelectionHistory

    -- | Map of keys held down.  Maintained by cmd_record_keys and accessed
    -- with 'keys_down'.
    -- The key is the modifier stripped of extraneous info, like mousedown
    -- position.  The value has complete info.
    , State -> Map Modifier Modifier
state_keys_down :: !(Map Modifier Modifier)
    -- | The block and track that have focus.  Commands that address
    -- a particular block or track will address these.
    , State -> Maybe ViewId
state_focused_view :: !(Maybe ViewId)
    -- | This contains a Rect for each screen.  The first one is the default
    -- one, if a default is needed, though normally views should show up next
    -- to other views.
    , State -> [Rect]
state_screens :: ![Rect.Rect]
    -- | Just indicates that the keycaps window is open.  The window is global,
    -- stored in "Ui.PtrMap", so I don't need to store it here.
    , State -> Maybe KeycapsState
state_keycaps :: !(Maybe KeycapsState)
    , State -> Maybe KeycapsUpdate
state_keycaps_update :: !(Maybe KeycapsUpdate)

    -- | This is similar to 'Ui.Block.view_status', except that it's global
    -- instead of per-view.  So changes are logged with a special prefix so
    -- logview can catch them.  Really I only need this map to suppress log
    -- spam.
    , State -> Map Text Text
state_global_status :: !(Map Text Text)
    , State -> PlayState
state_play :: !PlayState
    , State -> Hooks
state_hooks :: !Hooks

    -- External device tracking.
    -- | MIDI state of WriteDevices.
    , State -> WriteDeviceState
state_wdev_state :: !WriteDeviceState

    -- | MIDI state of ReadDevices, including configuration like pitch bend
    -- range.
    , State -> ReadDeviceState
state_rdev_state :: !InputNote.ReadDeviceState
    , State -> EditState
state_edit :: !EditState
    -- | The status return for this Cmd.  This is used only by the REPL, since
    -- non-REPL cmds simply return Status as their return value.  REPL cmds
    -- can't do that because they commonly use the return value to return
    -- an interesting String back to the REPL.
    , State -> Status
state_repl_status :: !Status
    -- | Enable various debug printing to stdout.
    , State -> Bool
state_debug :: !Bool
    } deriving (Int -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

data SaveFile = SaveState !Path.Canonical | SaveRepo !Path.Canonical
    deriving (Int -> SaveFile -> ShowS
[SaveFile] -> ShowS
SaveFile -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SaveFile] -> ShowS
$cshowList :: [SaveFile] -> ShowS
show :: SaveFile -> String
$cshow :: SaveFile -> String
showsPrec :: Int -> SaveFile -> ShowS
$cshowsPrec :: Int -> SaveFile -> ShowS
Show, SaveFile -> SaveFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SaveFile -> SaveFile -> Bool
$c/= :: SaveFile -> SaveFile -> Bool
== :: SaveFile -> SaveFile -> Bool
$c== :: SaveFile -> SaveFile -> Bool
Eq)
data Writable = ReadWrite | ReadOnly deriving (Int -> Writable -> ShowS
[Writable] -> ShowS
Writable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Writable] -> ShowS
$cshowList :: [Writable] -> ShowS
show :: Writable -> String
$cshow :: Writable -> String
showsPrec :: Int -> Writable -> ShowS
$cshowsPrec :: Int -> Writable -> ShowS
Show, Writable -> Writable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Writable -> Writable -> Bool
$c/= :: Writable -> Writable -> Bool
== :: Writable -> Writable -> Bool
$c== :: Writable -> Writable -> Bool
Eq)

-- | This tracks how much the score has been saved to disk.
data Saved = Saved {
    Saved -> SavedState
_saved_state :: !SavedState
    , Saved -> Bool
_editor_open :: !Bool
    } deriving (Saved -> Saved -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Saved -> Saved -> Bool
$c/= :: Saved -> Saved -> Bool
== :: Saved -> Saved -> Bool
$c== :: Saved -> Saved -> Bool
Eq, Int -> Saved -> ShowS
[Saved] -> ShowS
Saved -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Saved] -> ShowS
$cshowList :: [Saved] -> ShowS
show :: Saved -> String
$cshow :: Saved -> String
showsPrec :: Int -> Saved -> ShowS
$cshowsPrec :: Int -> Saved -> ShowS
Show)

-- True if state is synced to disk, either because it was just saved and
-- not significantly changed, or because it was just loaded.
data SavedState =
    -- | Just loaded from a file.  This is almost like SavedChanges, except
    -- that it's required so 'Cmd.Internal.sync_status' can tell the difference
    -- between the state changing because it was just loaded (set to
    -- SavedChanges) and changing due to an edit (set to UnsavedChanges).
    JustLoaded
    | UnsavedChanges
    | SavedChanges
    deriving (SavedState -> SavedState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SavedState -> SavedState -> Bool
$c/= :: SavedState -> SavedState -> Bool
== :: SavedState -> SavedState -> Bool
$c== :: SavedState -> SavedState -> Bool
Eq, Int -> SavedState -> ShowS
[SavedState] -> ShowS
SavedState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SavedState] -> ShowS
$cshowList :: [SavedState] -> ShowS
show :: SavedState -> String
$cshow :: SavedState -> String
showsPrec :: Int -> SavedState -> ShowS
$cshowsPrec :: Int -> SavedState -> ShowS
Show)

data KeycapsUpdate =
    KeycapsUpdate KeycapsState (Maybe ((Int, Int), KeycapsT.Layout))
        KeycapsT.RawBindings
    | KeycapsClose
    deriving (Int -> KeycapsUpdate -> ShowS
[KeycapsUpdate] -> ShowS
KeycapsUpdate -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeycapsUpdate] -> ShowS
$cshowList :: [KeycapsUpdate] -> ShowS
show :: KeycapsUpdate -> String
$cshow :: KeycapsUpdate -> String
showsPrec :: Int -> KeycapsUpdate -> ShowS
$cshowsPrec :: Int -> KeycapsUpdate -> ShowS
Show)

-- | The set of things that can affect a keycaps window.  So when this changes,
-- the window has to be updated.  I assume the KeycapsT.Layout is constant, so
-- it's not in here, which allows me to cache global keymaps in CAFs.
data KeycapsState = KeycapsState {
    KeycapsState -> Set Modifier
kc_mods :: Set Modifier
    , KeycapsState -> Int
kc_octave :: Pitch.Octave
    , KeycapsState -> Bool
kc_is_kbd_entry :: Bool
    , KeycapsState -> Maybe Type
kc_track_type :: Maybe ParseTitle.Type
    , KeycapsState -> Maybe Instrument
kc_instrument :: Maybe ScoreT.Instrument
    , KeycapsState -> Maybe ScaleId
kc_scale_id :: Maybe Pitch.ScaleId
    } deriving (Int -> KeycapsState -> ShowS
[KeycapsState] -> ShowS
KeycapsState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeycapsState] -> ShowS
$cshowList :: [KeycapsState] -> ShowS
show :: KeycapsState -> String
$cshow :: KeycapsState -> String
showsPrec :: Int -> KeycapsState -> ShowS
$cshowsPrec :: Int -> KeycapsState -> ShowS
Show, KeycapsState -> KeycapsState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeycapsState -> KeycapsState -> Bool
$c/= :: KeycapsState -> KeycapsState -> Bool
== :: KeycapsState -> KeycapsState -> Bool
$c== :: KeycapsState -> KeycapsState -> Bool
Eq)

-- | Absolute directory of the save file.
state_save_dir :: State -> Maybe FilePath
state_save_dir :: State -> Maybe String
state_save_dir State
state = case State -> Maybe (Writable, SaveFile)
state_save_file State
state of
    Maybe (Writable, SaveFile)
Nothing -> forall a. Maybe a
Nothing
    Just (Writable
_, SaveState Canonical
fn) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeDirectory forall a b. (a -> b) -> a -> b
$ Canonical -> String
Path.to_path Canonical
fn
    Just (Writable
_, SaveRepo Canonical
repo) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeDirectory forall a b. (a -> b) -> a -> b
$ Canonical -> String
Path.to_path Canonical
repo

-- | Unique name for this score, for the global im cache.
score_path :: State -> FilePath
score_path :: State -> String
score_path State
state = case State -> Maybe (Writable, SaveFile)
state_save_file State
state of
    -- #untitled so it's clear where it came from and unlikely to conflict with
    -- a real filename.
    Maybe (Writable, SaveFile)
Nothing -> String
"#untitled"
    Just (Writable
_, SaveState Canonical
fn) -> Canonical -> String
strip Canonical
fn
    Just (Writable
_, SaveRepo Canonical
repo) -> Canonical -> String
strip Canonical
repo
    where
    strip :: Canonical -> String
strip = Canonical -> Canonical -> String
Path.drop_prefix (Config -> Canonical
config_save_dir (State -> Config
state_config State
state))

-- | A loaded and parsed ky file, or an error string.  This also has the files
-- loaded and their timestamps, to detect when one has changed.
data KyCache =
    KyCache !(Either Text (Derive.Builtins, Derive.InstrumentAliases))
        !Fingerprint
    -- | This disables the cache mechanism.  Tests use this to avoid having
    -- to set SaveFile.
    | PermanentKy !(Derive.Builtins, Derive.InstrumentAliases)
    deriving (Int -> KyCache -> ShowS
[KyCache] -> ShowS
KyCache -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KyCache] -> ShowS
$cshowList :: [KyCache] -> ShowS
show :: KyCache -> String
$cshow :: KyCache -> String
showsPrec :: Int -> KyCache -> ShowS
$cshowsPrec :: Int -> KyCache -> ShowS
Show)

-- | Keep track of loaded files and a fingerprint for their contents.  This is
-- used to detect when they should be reloaded.
data Fingerprint = Fingerprint ![FilePath] !Int
    deriving (Fingerprint -> Fingerprint -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c== :: Fingerprint -> Fingerprint -> Bool
Eq, Int -> Fingerprint -> ShowS
[Fingerprint] -> ShowS
Fingerprint -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fingerprint] -> ShowS
$cshowList :: [Fingerprint] -> ShowS
show :: Fingerprint -> String
$cshow :: Fingerprint -> String
showsPrec :: Int -> Fingerprint -> ShowS
$cshowsPrec :: Int -> Fingerprint -> ShowS
Show)

instance Semigroup Fingerprint where
    Fingerprint [String]
fnames1 Int
fprint1 <> :: Fingerprint -> Fingerprint -> Fingerprint
<> Fingerprint [String]
fnames2 Int
fprint2 =
        [String] -> Int -> Fingerprint
Fingerprint ([String]
fnames1forall a. Semigroup a => a -> a -> a
<>[String]
fnames2) (forall a. Hashable a => Int -> a -> Int
Hashable.hashWithSalt Int
fprint1 Int
fprint2)
instance Monoid Fingerprint where
    mempty :: Fingerprint
mempty = [String] -> Int -> Fingerprint
Fingerprint [] Int
0
    mappend :: Fingerprint -> Fingerprint -> Fingerprint
mappend = forall a. Semigroup a => a -> a -> a
(<>)
instance Pretty Fingerprint where
    pretty :: Fingerprint -> Text
pretty (Fingerprint [String]
files Int
word) = forall a. Pretty a => a -> Text
pretty [String]
files forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Int
word

fingerprint :: [Ky.Loaded] -> Fingerprint
fingerprint :: [Loaded] -> Fingerprint
fingerprint [Loaded]
imports =
    -- The code in 'Ui.ky' gets "" for its filename.
    [String] -> Int -> Fingerprint
Fingerprint (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
fnames)
        (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Hashable a => Int -> a -> Int
Hashable.hashWithSalt Int
0 [Text]
contents)
    where
    ([String]
fnames, [Text]
contents) = forall a b. [(a, b)] -> ([a], [b])
unzip
        [(String
fname, Text
content) | Ky.Loaded String
fname Text
content <- [Loaded]
imports]

initial_state :: Config -> State
initial_state :: Config -> State
initial_state Config
config = State
    { state_config :: Config
state_config = Config
config
    , state_save_file :: Maybe (Writable, SaveFile)
state_save_file = forall a. Maybe a
Nothing
    , state_saved :: Saved
state_saved = SavedState -> Bool -> Saved
Saved SavedState
JustLoaded Bool
False
    , state_ky_cache :: Maybe KyCache
state_ky_cache = forall a. Maybe a
Nothing
    , state_derive_immediately :: Set BlockId
state_derive_immediately = forall a. Set a
Set.empty
    -- This is a dummy entry needed to bootstrap a Cmd.State.  Normally
    -- 'hist_present' should always have the current state, but the initial
    -- setup cmd needs a State too.
    , state_history :: History
state_history = HistoryEntry -> History
initial_history (State -> HistoryEntry
empty_history_entry State
Ui.empty)
    , state_history_config :: HistoryConfig
state_history_config = HistoryConfig
empty_history_config
    , state_history_collect :: HistoryCollect
state_history_collect = HistoryCollect
empty_history_collect
    , state_selection_history :: SelectionHistory
state_selection_history = SelectionHistory
empty_selection_history
    , state_keys_down :: Map Modifier Modifier
state_keys_down = forall k a. Map k a
Map.empty
    , state_focused_view :: Maybe ViewId
state_focused_view = forall a. Maybe a
Nothing
    , state_screens :: [Rect]
state_screens = []
    , state_keycaps :: Maybe KeycapsState
state_keycaps = forall a. Maybe a
Nothing
    , state_keycaps_update :: Maybe KeycapsUpdate
state_keycaps_update = forall a. Maybe a
Nothing
    , state_global_status :: Map Text Text
state_global_status = forall k a. Map k a
Map.empty
    , state_play :: PlayState
state_play = PlayState
initial_play_state
    , state_hooks :: Hooks
state_hooks = forall a. Monoid a => a
mempty

    , state_wdev_state :: WriteDeviceState
state_wdev_state = WriteDeviceState
empty_wdev_state
    , state_rdev_state :: ReadDeviceState
state_rdev_state = ReadDeviceState
InputNote.empty_rdev_state
    , state_edit :: EditState
state_edit = EditState
initial_edit_state
    , state_repl_status :: Status
state_repl_status = Status
Continue
    , state_debug :: Bool
state_debug = Bool
False
    }

-- | Reset the parts of the State which are specific to a \"session\".  This
-- should be called whenever an entirely new state is loaded.
reinit_state :: HistoryEntry -> State -> State
reinit_state :: HistoryEntry -> State -> State
reinit_state HistoryEntry
present State
cstate = State
cstate
    { state_history :: History
state_history = HistoryEntry -> History
initial_history HistoryEntry
present
    -- Performance threads should have been killed by the caller.
    , state_play :: PlayState
state_play = PlayState
initial_play_state
        { state_play_step :: TimeStep
state_play_step = PlayState -> TimeStep
state_play_step (State -> PlayState
state_play State
cstate) }
    -- This is essential, otherwise lots of cmds break on the bad reference.
    , state_focused_view :: Maybe ViewId
state_focused_view = forall a. Maybe a
Nothing
    , state_edit :: EditState
state_edit = EditState
initial_edit_state
        { state_time_step :: TimeStep
state_time_step = EditState -> TimeStep
state_time_step (State -> EditState
state_edit State
cstate) }
    }

-- ** Config

-- | Config type variables that change never or rarely.  These mostly come from
-- the "App.StaticConfig".
data Config = Config {
    -- | App root, initialized from 'Config.get_app_dir'.
    Config -> AppDir
config_app_dir :: !Path.AppDir
    , Config -> Canonical
config_save_dir :: !Path.Canonical
    , Config -> Interface
config_midi_interface :: !Midi.Interface.Interface
    -- | Search path for local definition files, from 'Config.definition_path'.
    , Config -> [String]
config_ky_paths :: ![FilePath]
    -- | Reroute MIDI inputs and outputs.  These come from
    -- 'App.StaticConfig.rdev_map' and 'App.StaticConfig.wdev_map' and probably
    -- shouldn't be changed at runtime.
    , Config -> Map ReadDevice ReadDevice
config_rdev_map :: !(Map Midi.ReadDevice Midi.ReadDevice)
    -- | WriteDevices can be score-specific, though, so another map is kept in
    -- 'Ui.State', which may override the one here.
    , Config -> Map WriteDevice WriteDevice
config_wdev_map :: !(Map Midi.WriteDevice Midi.WriteDevice)
    , Config -> InstrumentDb
config_instrument_db :: !InstrumentDb
    -- | Library of calls for the deriver.
    , Config -> Builtins
config_builtins :: !Derive.Builtins
    , Config -> Map Highlight Color
config_highlight_colors :: !(Map Color.Highlight Color.Color)
    , Config -> Config
config_im :: !Shared.Config.Config
    -- | If True, play im audio directly instead of via the play_cache VST.
    -- This means you don't need a DAW, but if you have MIDI instruments
    -- they probably won't be very in sync.
    , Config -> Bool
config_im_play_direct :: Bool
    , Config -> User
config_git_user :: !SaveGitT.User
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

-- | Get a midi writer that takes the 'config_wdev_map' into account.
state_midi_writer :: State -> Midi.Interface.Message -> IO ()
state_midi_writer :: State -> Message -> IO ()
state_midi_writer State
state Message
imsg = do
    let out :: Message
out = case Message
imsg of
            Midi.Interface.Midi WriteMessage
wmsg -> WriteMessage -> Message
Midi.Interface.Midi forall a b. (a -> b) -> a -> b
$ WriteMessage -> WriteMessage
map_wdev WriteMessage
wmsg
            Message
_ -> Message
imsg
    Maybe Text
mb_err <- forall write_message.
RawInterface write_message -> write_message -> IO (Maybe Text)
Midi.Interface.write_message
        (Config -> Interface
config_midi_interface (State -> Config
state_config State
state)) Message
out
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Text
mb_err forall a b. (a -> b) -> a -> b
$ \Text
err ->
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"error writing " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Message
out forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
    where
    map_wdev :: WriteMessage -> WriteMessage
map_wdev (Midi.WriteMessage WriteDevice
wdev RealTime
time Message
msg) =
        WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage (WriteDevice -> WriteDevice
lookup_wdev WriteDevice
wdev) RealTime
time Message
msg
    lookup_wdev :: WriteDevice -> WriteDevice
lookup_wdev WriteDevice
wdev = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault WriteDevice
wdev WriteDevice
wdev
        (Config -> Map WriteDevice WriteDevice
config_wdev_map (State -> Config
state_config State
state))

-- | Convert a relative path to place it in the app dir.
to_absolute :: State -> Path.Relative -> FilePath
to_absolute :: State -> Relative -> String
to_absolute State
state = AppDir -> Relative -> String
Path.to_absolute (Config -> AppDir
config_app_dir (State -> Config
state_config State
state))

-- | This was previously in 'Config', and configured via StaticConfig.  But it
-- turns out I don't really use StaticConfig.  It has a name here just so
-- I don't get references to 'Scale.All.lookup_scale' everywhere.
lookup_scale :: Derive.LookupScale
lookup_scale :: LookupScale
lookup_scale = LookupScale
Scale.All.lookup_scale

-- ** PlayState

-- | State concerning derivation, performance, and playing the performance.
data PlayState = PlayState {
    -- | Transport control channel for the player, if one is running.
    -- This is a list even though I only expect one to run at a time.  The
    -- reason is that if starting a new one stops the old one, there will
    -- be a small window where the old one has not exited yet.  It's probably
    -- better to wait for the previous one to exit, but I've also had bugs
    -- where play gets stuck on, that makes me think with the concurrency I'm
    -- going to wind up with overlapping anyway, so I may as well handle it
    -- when I see it.
    PlayState -> [PlayControl]
state_play_control :: ![Transport.PlayControl]
    -- | When changes are made to a block, its performance will be
    -- recalculated in the background.  When the Performance is forced, it will
    -- replace the existing performance in 'state_performance', if any.  This
    -- means there will be a window in which the performance is out of date,
    -- but this is better than hanging the responder every time it touches an
    -- insufficiently lazy part of the performance.
    , PlayState -> Map BlockId Performance
state_performance :: !(Map BlockId Performance)
    -- | However, some cmds, like play, want the most up to date performance
    -- even if they have to wait for it.  This map will be updated
    -- immediately.
    , PlayState -> Map BlockId Performance
state_current_performance :: !(Map BlockId Performance)
    -- | Keep track of current thread working on each performance.  If a
    -- new performance is needed before the old one is complete, it can be
    -- killed off.
    , PlayState -> Map BlockId Thread
state_performance_threads :: !(Map BlockId Thread)
    -- | Some play commands start playing from a short distance before the
    -- cursor.
    , PlayState -> TimeStep
state_play_step :: !TimeStep.TimeStep
    -- | Contain a StepState if step play is active.  Managed in
    -- "Cmd.StepPlay".
    , PlayState -> Maybe StepState
state_step :: !(Maybe StepState)
    -- | Globally speed up or slow down performance.  It mutiplies the
    -- timestamps by the reciprocal of this amount, so 2 will play double
    -- speed, and 0.5 will play half speed.
    , PlayState -> RealTime
state_play_multiplier :: RealTime
    -- | If set, synchronize with a DAW when the selection is set, and on play
    -- and stop.
    , PlayState -> Maybe SyncConfig
state_sync :: !(Maybe SyncConfig)
    -- | Track im progress as updated by 'Msg.ImRenderingRange'.  This is
    -- ultimately displayed on the GUI, but I keep track here so I can take
    -- minimum and maximum when multiple instruments live on one track.
    , PlayState
-> Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
state_im_progress :: !(Map BlockId (Map TrackId
        (Map ScoreT.Instrument (RealTime, RealTime))))
    , PlayState -> Maybe PlayCmd
state_previous_play :: !(Maybe PlayCmd)
    } deriving (Int -> PlayState -> ShowS
[PlayState] -> ShowS
PlayState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlayState] -> ShowS
$cshowList :: [PlayState] -> ShowS
show :: PlayState -> String
$cshow :: PlayState -> String
showsPrec :: Int -> PlayState -> ShowS
$cshowsPrec :: Int -> PlayState -> ShowS
Show)

-- | Wrapper around CmdId PlayArgs to make it Showable.
data PlayCmd = PlayCmd !Text !(CmdId PlayArgs)
instance Show PlayCmd where
    show :: PlayCmd -> String
show (PlayCmd Text
name CmdId PlayArgs
_) = String
"PlayCmd " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
name

-- | Wrap Async to make it showable.  I use Async instead of ThreadId because
-- I want to make sure they can run their finalizers when the app quits, and
-- I can wait on an Async, but not on a ThreadId.  At the moment, the
-- finalizers are killing im subprocesses.  'kill_thread' uses Async.cancel,
-- which synchronously waits for the thread to complete.
newtype Thread = Thread (Async.Async ())

instance Show Thread where
    show :: Thread -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Async a -> ThreadId
Async.asyncThreadId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Thread -> Async ()
u
        where u :: Thread -> Async ()
u (Thread Async ()
t) = Async ()
t

kill_thread :: Thread -> IO ()
kill_thread :: Thread -> IO ()
kill_thread (Thread Async ()
async) = forall a. Async a -> IO ()
Async.cancel Async ()
async

kill_performance_threads :: State -> IO ()
kill_performance_threads :: State -> IO ()
kill_performance_threads =
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Thread -> IO ()
kill_thread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Map BlockId Thread
state_performance_threads forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
state_play

-- | Get currently evaluating root BlockIds.
running_threads :: CmdT IO [BlockId]
running_threads :: CmdT IO [BlockId]
running_threads = do
    [(BlockId, Thread)]
threads <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Map BlockId Thread
state_performance_threads forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
state_play
    [(BlockId, Thread)]
alive <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Thread -> IO Bool
is_alive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(BlockId, Thread)]
threads
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(BlockId, Thread)]
alive
    where
    is_alive :: Thread -> IO Bool
is_alive (Thread Async ()
async) = forall a. Maybe a -> Bool
Maybe.isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Async a -> IO (Maybe (Either SomeException a))
Async.poll Async ()
async

initial_play_state :: PlayState
initial_play_state :: PlayState
initial_play_state = PlayState
    { state_play_control :: [PlayControl]
state_play_control = []
    , state_performance :: Map BlockId Performance
state_performance = forall k a. Map k a
Map.empty
    , state_current_performance :: Map BlockId Performance
state_current_performance = forall k a. Map k a
Map.empty
    , state_performance_threads :: Map BlockId Thread
state_performance_threads = forall k a. Map k a
Map.empty
    , state_play_step :: TimeStep
state_play_step = Step -> TimeStep
TimeStep.time_step forall a b. (a -> b) -> a -> b
$
        MarklistMatch -> Rank -> Step
TimeStep.RelativeMark MarklistMatch
TimeStep.AllMarklists Rank
Meter.Section
    , state_step :: Maybe StepState
state_step = forall a. Maybe a
Nothing
    , state_play_multiplier :: RealTime
state_play_multiplier = Double -> RealTime
RealTime.seconds Double
1
    , state_sync :: Maybe SyncConfig
state_sync = forall a. Maybe a
Nothing
    , state_im_progress :: Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
state_im_progress = forall a. Monoid a => a
mempty
    , state_previous_play :: Maybe PlayCmd
state_previous_play = forall a. Maybe a
Nothing
    }

-- | Step play is a way of playing back the performance in non-realtime.
data StepState = StepState {
    -- - constant
    -- | Keep track of the view step play was started in, so I know where to
    -- display the selection.
    StepState -> ViewId
step_view_id :: !ViewId
    -- | If step play only applies to a few tracks, list them.  If null,
    -- step play applies to all tracks.
    , StepState -> [Int]
step_tracknums :: [TrackNum]

    -- - modified
    -- | MIDI states before the step play position, in descending order.
    , StepState -> [(ScoreTime, State)]
step_before :: ![(ScoreTime, Midi.State.State)]
    -- | MIDI states after the step play position, in asceding order.
    , StepState -> [(ScoreTime, State)]
step_after :: ![(ScoreTime, Midi.State.State)]
    } deriving (Int -> StepState -> ShowS
[StepState] -> ShowS
StepState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StepState] -> ShowS
$cshowList :: [StepState] -> ShowS
show :: StepState -> String
$cshow :: StepState -> String
showsPrec :: Int -> StepState -> ShowS
$cshowsPrec :: Int -> StepState -> ShowS
Show)

-- | Configure synchronization.  MMC is used to set the play position and MTC
-- is used to start and stop playing.
--
-- MMC has start and stop msgs, but they seem useless, since they're sysexes,
-- which are not delivered precisely.
data SyncConfig = SyncConfig {
    SyncConfig -> WriteDevice
sync_device :: !Midi.WriteDevice
    -- | Send MMC to this device.
    , SyncConfig -> Channel
sync_device_id :: !Mmc.DeviceId
    -- | If true, send MTC on the 'sync_device'.  If this is set, MMC play and
    -- stop will be omitted, since the presence of MTC should be enough to get
    -- the DAW started, provided it's in external sync mode.
    --
    -- DAWs tend to spend a long time synchronizing, presumably because
    -- hardware devices take time to spin up.  That's unnecessary in software,
    -- so in Cubase you can set \"lock frames\" to 2, and in Reaper you can set
    -- \"synchronize by seeking ahead\" to 67ms.
    , SyncConfig -> Bool
sync_mtc :: !Bool
    , SyncConfig -> FrameRate
sync_frame_rate :: !Midi.FrameRate
    } deriving (Int -> SyncConfig -> ShowS
[SyncConfig] -> ShowS
SyncConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyncConfig] -> ShowS
$cshowList :: [SyncConfig] -> ShowS
show :: SyncConfig -> String
$cshow :: SyncConfig -> String
showsPrec :: Int -> SyncConfig -> ShowS
$cshowsPrec :: Int -> SyncConfig -> ShowS
Show)

instance Pretty SyncConfig where
    format :: SyncConfig -> Doc
format (SyncConfig WriteDevice
dev Channel
dev_id Bool
mtc FrameRate
rate) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"SyncConfig"
        [ (Text
"device", forall a. Pretty a => a -> Doc
Pretty.format WriteDevice
dev)
        , (Text
"device_id", forall a. Pretty a => a -> Doc
Pretty.format Channel
dev_id)
        , (Text
"mtc", forall a. Pretty a => a -> Doc
Pretty.format Bool
mtc)
        , (Text
"frame_rate", Text -> Doc
Pretty.text (forall a. Show a => a -> Text
showt FrameRate
rate))
        ]

-- ** hooks

-- | Hooks are Cmds that run after some event.
newtype Hooks = Hooks {
    -- | Run when the selection changes.
    Hooks -> [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
hooks_selection :: [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
    }

-- | Just a 'Sel.Selection' annotated with its BlockId and TrackId.  There's
-- no deep reason for it, it just saves a bit of work for selection hooks.
type TrackSelection = (Sel.Selection, BlockId, Maybe TrackId)

instance Show Hooks where
    show :: Hooks -> String
show (Hooks [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel) = String
"((Hooks " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel) forall a. [a] -> [a] -> [a]
++ String
"))"

instance Semigroup Hooks where
    Hooks [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel1 <> :: Hooks -> Hooks -> Hooks
<> Hooks [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel2 = [[(ViewId, Maybe TrackSelection)] -> CmdId ()] -> Hooks
Hooks ([[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel1 forall a. Semigroup a => a -> a -> a
<> [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel2)
instance Monoid Hooks where
    mempty :: Hooks
mempty = [[(ViewId, Maybe TrackSelection)] -> CmdId ()] -> Hooks
Hooks []
    mappend :: Hooks -> Hooks -> Hooks
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- ** EditState

-- | Editing state, modified in the course of editing.
data EditState = EditState {
    -- | Edit mode enables various commands that write to tracks.
    EditState -> EditMode
state_edit_mode :: !EditMode
    -- | True if the floating input edit is open.
    , EditState -> Bool
state_floating_input :: !Bool
    -- | Whether or not to advance the insertion point after a note is
    -- entered.
    , EditState -> Bool
state_advance :: Bool
    -- | Chord mode means the note is considered entered when all NoteOffs
    -- have been received.  While a note is held down, the insertion point will
    -- move to the next note track with the same instrument so you can
    -- enter chords.
    --
    -- When chord mode is off, the note is considered entered as soon as
    -- its NoteOn is received.
    , EditState -> Bool
state_chord :: Bool
    -- | Try to find or create a 'Controls.dynamic' track for to record
    -- 'InputNote.Input' velocity, similar to how a pitch track is edited and
    -- created.
    , EditState -> Bool
state_record_velocity :: Bool
    -- | Use the alphanumeric keys to enter notes in addition to midi input.
    , EditState -> Bool
state_kbd_entry :: !Bool
    -- | Default time step for cursor movement.
    , EditState -> TimeStep
state_time_step :: !TimeStep.TimeStep
    -- | Used for note duration.  It's separate from 'state_time_step' to
    -- allow for tracker-style note entry where newly entered notes extend to
    -- the next note or the end of the block.
    , EditState -> TimeStep
state_note_duration :: !TimeStep.TimeStep
    -- | If this is Negative, create notes with negative durations.
    , EditState -> Orientation
state_note_orientation :: !Types.Orientation
    -- | New notes get this text by default.  This way, you can enter a series
    -- of notes with the same attributes, or whatever.
    , EditState -> Text
state_note_text :: !Text
    -- | Transpose note entry on the keyboard by this many octaves.  It's by
    -- octave instead of scale degree since scales may have different numbers
    -- of notes per octave.
    , EditState -> Int
state_kbd_entry_octave :: !Pitch.Octave
    , EditState -> RecordedActions
state_recorded_actions :: !RecordedActions
    , EditState -> Map Instrument Attributes
state_instrument_attributes :: !(Map ScoreT.Instrument Attrs.Attributes)
    -- | See 'set_edit_box'.
    , EditState -> (Box, Box)
state_edit_box :: !(Block.Box, Block.Box)
    } deriving (EditState -> EditState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EditState -> EditState -> Bool
$c/= :: EditState -> EditState -> Bool
== :: EditState -> EditState -> Bool
$c== :: EditState -> EditState -> Bool
Eq, Int -> EditState -> ShowS
[EditState] -> ShowS
EditState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EditState] -> ShowS
$cshowList :: [EditState] -> ShowS
show :: EditState -> String
$cshow :: EditState -> String
showsPrec :: Int -> EditState -> ShowS
$cshowsPrec :: Int -> EditState -> ShowS
Show)

initial_edit_state :: EditState
initial_edit_state :: EditState
initial_edit_state = EditState {
    state_edit_mode :: EditMode
state_edit_mode = EditMode
NoEdit
    , state_floating_input :: Bool
state_floating_input = Bool
False
    , state_kbd_entry :: Bool
state_kbd_entry = Bool
False
    , state_advance :: Bool
state_advance = Bool
True
    , state_chord :: Bool
state_chord = Bool
False
    , state_record_velocity :: Bool
state_record_velocity = Bool
False
    , state_time_step :: TimeStep
state_time_step = PlayState -> TimeStep
state_play_step PlayState
initial_play_state
    , state_note_duration :: TimeStep
state_note_duration = TimeStep
TimeStep.event_edge
    , state_note_orientation :: Orientation
state_note_orientation = Orientation
Types.Positive
    , state_note_text :: Text
state_note_text = Text
""
    -- This should put middle C in the center of the kbd entry keys.
    , state_kbd_entry_octave :: Int
state_kbd_entry_octave = Int
3
    , state_recorded_actions :: RecordedActions
state_recorded_actions = forall a. Monoid a => a
mempty
    , state_instrument_attributes :: Map Instrument Attributes
state_instrument_attributes = forall a. Monoid a => a
mempty
    , state_edit_box :: (Box, Box)
state_edit_box = (Box
box, Box
box)
    } where box :: Box
box = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Color -> Char -> Box
Block.Box (Color, Char)
Config.bconfig_box

-- | These enable various commands to edit event text.  What exactly val
-- and method mean are dependent on the track.
data EditMode = NoEdit | ValEdit | MethodEdit deriving (EditMode -> EditMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EditMode -> EditMode -> Bool
$c/= :: EditMode -> EditMode -> Bool
== :: EditMode -> EditMode -> Bool
$c== :: EditMode -> EditMode -> Bool
Eq, Int -> EditMode -> ShowS
[EditMode] -> ShowS
EditMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EditMode] -> ShowS
$cshowList :: [EditMode] -> ShowS
show :: EditMode -> String
$cshow :: EditMode -> String
showsPrec :: Int -> EditMode -> ShowS
$cshowsPrec :: Int -> EditMode -> ShowS
Show)
instance Pretty EditMode where pretty :: EditMode -> Text
pretty = forall a. Show a => a -> Text
showt

type RecordedActions = Map Char Action

-- | Repeat a recorded action.
--
-- Select event and duration and hit shift-1 to record InsertEvent.
-- Text edits record ReplaceText, PrependText, or AppendText in the last
-- action field (bound to '.'), which you can then save.
data Action =
    -- | If a duration is given, the event has that duration, otherwise
    -- it gets the current time step.
    InsertEvent !(Maybe TrackTime) !Text
    | ReplaceText !Text | PrependText !Text | AppendText !Text
    deriving (Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show, Action -> Action -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq)

instance Pretty Action where
    pretty :: Action -> Text
pretty Action
act = case Action
act of
        InsertEvent Maybe ScoreTime
maybe_dur Text
text ->
            forall a. Pretty a => a -> Text
pretty Text
text forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Maybe ScoreTime
maybe_dur forall a. Semigroup a => a -> a -> a
<> Text
")"
        ReplaceText Text
text -> Text
"=" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
text
        PrependText Text
text -> forall a. Pretty a => a -> Text
pretty Text
text forall a. Semigroup a => a -> a -> a
<> Text
"+"
        AppendText Text
text -> Text
"+" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
text

-- *** midi devices

data WriteDeviceState = WriteDeviceState {
    -- Used by Cmd.MidiThru:
    -- | NoteId currently playing in each Addr.  An Addr may have >1 NoteId.
    WriteDeviceState -> Map NoteId Addr
wdev_note_addr :: !(Map InputNote.NoteId Patch.Addr)
    -- | The note id is not guaranteed to have any relationship to the key,
    -- so the MIDI NoteOff needs to know what key the MIDI NoteOn used.
    , WriteDeviceState -> Map NoteId Key
wdev_note_key :: !(Map InputNote.NoteId Midi.Key)
    -- | Map an addr to a number that increases when it's assigned a note.
    -- This is used along with 'wdev_serial' to implement addr round-robin.
    , WriteDeviceState -> Map Addr Int
wdev_addr_serial :: !(Map Patch.Addr Serial)
    -- | Next serial number for 'wdev_addr_serial'.
    , WriteDeviceState -> Int
wdev_serial :: !Serial
    -- | Last NoteId seen.  This is needed to emit controls (rather than just
    -- mapping them from MIDI input) because otherwise there's no way to know
    -- to which note they should be assigned.
    , WriteDeviceState -> Maybe NoteId
wdev_last_note_id :: !(Maybe InputNote.NoteId)

    -- Used by Cmd.PitchTrack:
    -- | NoteIds being entered into which pitch tracks.  When entering a chord,
    -- a PitchChange uses this to know which pitch track to update.
    , WriteDeviceState -> Map NoteId (BlockId, Int)
wdev_pitch_track :: !(Map InputNote.NoteId (BlockId, TrackNum))

    -- Used by no one, yet:  (TODO should someone use this?)
    -- | Remember the current patch of each addr.  More than one patch or
    -- keyswitch can share the same addr, so I need to keep track which one is
    -- active to minimize switches.
    , WriteDeviceState -> Map Addr Patch
wdev_addr_inst :: !(Map Patch.Addr Midi.Types.Patch)
    } deriving (WriteDeviceState -> WriteDeviceState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteDeviceState -> WriteDeviceState -> Bool
$c/= :: WriteDeviceState -> WriteDeviceState -> Bool
== :: WriteDeviceState -> WriteDeviceState -> Bool
$c== :: WriteDeviceState -> WriteDeviceState -> Bool
Eq, Int -> WriteDeviceState -> ShowS
[WriteDeviceState] -> ShowS
WriteDeviceState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteDeviceState] -> ShowS
$cshowList :: [WriteDeviceState] -> ShowS
show :: WriteDeviceState -> String
$cshow :: WriteDeviceState -> String
showsPrec :: Int -> WriteDeviceState -> ShowS
$cshowsPrec :: Int -> WriteDeviceState -> ShowS
Show)

type Serial = Int

empty_wdev_state :: WriteDeviceState
empty_wdev_state :: WriteDeviceState
empty_wdev_state = WriteDeviceState
    { wdev_note_addr :: Map NoteId Addr
wdev_note_addr = forall k a. Map k a
Map.empty
    , wdev_note_key :: Map NoteId Key
wdev_note_key = forall k a. Map k a
Map.empty
    , wdev_addr_serial :: Map Addr Int
wdev_addr_serial = forall k a. Map k a
Map.empty
    , wdev_serial :: Int
wdev_serial = Int
0
    , wdev_last_note_id :: Maybe NoteId
wdev_last_note_id = forall a. Maybe a
Nothing
    , wdev_pitch_track :: Map NoteId (BlockId, Int)
wdev_pitch_track = forall k a. Map k a
Map.empty
    , wdev_addr_inst :: Map Addr Patch
wdev_addr_inst = forall k a. Map k a
Map.empty
    }

-- *** performance

perf_tempo :: Performance -> Transport.TempoFunction
perf_tempo :: Performance -> TempoFunction
perf_tempo = [TrackWarp] -> TempoFunction
TrackWarp.tempo_func forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> [TrackWarp]
perf_warps

perf_inv_tempo :: Performance -> Transport.InverseTempoFunction
perf_inv_tempo :: Performance -> InverseTempoFunction
perf_inv_tempo = [TrackWarp] -> InverseTempoFunction
TrackWarp.inverse_tempo_func forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> [TrackWarp]
perf_warps

perf_closest_warp :: Performance -> Transport.ClosestWarpFunction
perf_closest_warp :: Performance -> ClosestWarpFunction
perf_closest_warp = [TrackWarp] -> ClosestWarpFunction
TrackWarp.closest_warp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Performance -> [TrackWarp]
perf_warps

-- *** instrument

-- | The code part of an instrument, i.e. the calls and cmds it brings into
-- scope.
--
-- This has to be in Cmd.Cmd for circular import reasons.
data InstrumentCode = InstrumentCode {
    InstrumentCode -> InstrumentCalls
inst_calls :: !Derive.InstrumentCalls
    , InstrumentCode -> InstrumentPostproc
inst_postproc :: !InstrumentPostproc
    , InstrumentCode -> [HandlerId]
inst_cmds :: ![HandlerId]
    -- | An optional specialized cmd to write Thru.  This is separate from
    -- 'inst_cmds' so it can be run wherever the instrument needs special thru,
    -- not just in the instrument's note track.  This way custom thru works in
    -- the pitch track too.
    , InstrumentCode -> Maybe ThruFunction
inst_thru :: !(Maybe ThruFunction)
    }

type ThruFunction =
    Scale.Scale -> Attrs.Attributes -> InputNote.Input -> CmdId [Thru]

-- | Process each event before conversion.  This is like a postproc call,
-- but it can only map events 1:1 and you don't have to explicitly call it.
--
-- This can change the duration, but should not change 'Score.event_start',
-- because the events are not resorted afterwards.  Also, it's applied during
-- conversion, so it only makes sense to modify 'Score.event_duration',
-- 'Score.event_controls', 'Score.event_pitch', and 'Score.event_environ'.
-- TODO so I could have it return just those?  But then it has to return Maybe
-- to not modify and needs a record type.
type InstrumentPostproc = Score.Event -> (Score.Event, [Log.Msg])

instance Show InstrumentCode where show :: InstrumentCode -> String
show InstrumentCode
_ = String
"((InstrumentCode))"
instance Pretty InstrumentCode where
    format :: InstrumentCode -> Doc
format (InstrumentCode InstrumentCalls
calls InstrumentPostproc
_ [HandlerId]
cmds Maybe ThruFunction
thru) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"InstrumentCode"
        [ (Text
"calls", forall a. Pretty a => a -> Doc
Pretty.format InstrumentCalls
calls)
        , (Text
"cmds", forall a. Pretty a => a -> Doc
Pretty.format [HandlerId]
cmds)
        , (Text
"thru", forall a. Pretty a => a -> Doc
Pretty.format Maybe ThruFunction
thru)
        ]

make_derive_instrument :: ResolvedInstrument -> Derive.Instrument
make_derive_instrument :: ResolvedInstrument -> Instrument
make_derive_instrument ResolvedInstrument
resolved = Derive.Instrument
    { inst_calls :: InstrumentCalls
inst_calls = InstrumentCode -> InstrumentCalls
inst_calls forall a b. (a -> b) -> a -> b
$ forall code. Common code -> code
Common.common_code forall a b. (a -> b) -> a -> b
$ forall code. Inst code -> Common code
Inst.inst_common forall a b. (a -> b) -> a -> b
$
        ResolvedInstrument -> Inst
inst_instrument ResolvedInstrument
resolved
    , inst_environ :: Environ
inst_environ = Environ -> Environ
REnv.convert forall a b. (a -> b) -> a -> b
$
        Config -> Environ
Common.config_environ forall a b. (a -> b) -> a -> b
$ ResolvedInstrument -> Config
inst_common_config ResolvedInstrument
resolved
    , inst_controls :: ControlValMap
inst_controls = Config -> ControlValMap
Common.config_controls (ResolvedInstrument -> Config
inst_common_config ResolvedInstrument
resolved)
    , inst_attributes :: [Attributes]
inst_attributes = forall code. Inst code -> [Attributes]
Inst.inst_attributes (ResolvedInstrument -> Inst
inst_instrument ResolvedInstrument
resolved)
    , inst_elements :: Set Text
inst_elements = case forall code. Inst code -> Backend
Inst.inst_backend (ResolvedInstrument -> Inst
inst_instrument ResolvedInstrument
resolved) of
        Inst.Im Patch
patch -> Patch -> Set Text
Im.Patch.patch_elements Patch
patch
        Backend
_ -> forall a. Monoid a => a
mempty
    }

empty_code :: InstrumentCode
empty_code :: InstrumentCode
empty_code = InstrumentCode
    { inst_calls :: InstrumentCalls
inst_calls = forall a. Monoid a => a
mempty
    , inst_postproc :: InstrumentPostproc
inst_postproc = (,[])
    , inst_cmds :: [HandlerId]
inst_cmds = []
    , inst_thru :: Maybe ThruFunction
inst_thru = forall a. Maybe a
Nothing
    }

-- | Instantiate 'Inst.Db' with the code type.  The only reason the Db has the
-- type parameter is so I can define it in its own module without a circular
-- import.
type InstrumentDb = Inst.Db InstrumentCode
-- | Like 'InstrumentDb'.
type Inst = Inst.Inst InstrumentCode


-- *** history

-- | Ghosts of state past, present, and future.
data History = History {
    History -> [HistoryEntry]
hist_past :: ![HistoryEntry]
    -- | The present is actually the immediate past.  When you undo, the
    -- undo itself is actually in the future of the state you want to undo.
    -- So another way of looking at it is that you undo from the past to
    -- a point further in the past.  But since you always require a \"recent
    -- past\" to exist, it's more convenient to break it out and call it the
    -- \"present\".  Isn't time travel confusing?
    , History -> HistoryEntry
hist_present :: !HistoryEntry
    , History -> [HistoryEntry]
hist_future :: ![HistoryEntry]
    , History -> Maybe LastCmd
hist_last_cmd :: !(Maybe LastCmd)
    } deriving (Int -> History -> ShowS
[History] -> ShowS
History -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [History] -> ShowS
$cshowList :: [History] -> ShowS
show :: History -> String
$cshow :: History -> String
showsPrec :: Int -> History -> ShowS
$cshowsPrec :: Int -> History -> ShowS
Show)

initial_history :: HistoryEntry -> History
initial_history :: HistoryEntry -> History
initial_history HistoryEntry
present = [HistoryEntry]
-> HistoryEntry -> [HistoryEntry] -> Maybe LastCmd -> History
History [] HistoryEntry
present [] forall a. Maybe a
Nothing

-- | Record some information about the last cmd for the benefit of
-- 'Cmd.Undo.maintain_history'.
data LastCmd =
    -- | This cmd set the state because it was an undo or redo.  Otherwise undo
    -- and redo themselves would be recorded and multiple undo would be
    -- impossible!
    UndoRedo
    -- | This cmd set the state because of a load.  This should reset all the
    -- history so I can start loading from the new state's history.
    | Load (Maybe GitT.Commit) [Text]
    deriving (Int -> LastCmd -> ShowS
[LastCmd] -> ShowS
LastCmd -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LastCmd] -> ShowS
$cshowList :: [LastCmd] -> ShowS
show :: LastCmd -> String
$cshow :: LastCmd -> String
showsPrec :: Int -> LastCmd -> ShowS
$cshowsPrec :: Int -> LastCmd -> ShowS
Show)

data HistoryConfig = HistoryConfig {
    -- | Keep this many previous history entries in memory.
    HistoryConfig -> Int
hist_keep :: !Int
    -- | Checkpoints are saved relative to the state at the next checkpoint.
    -- So it's important to keep the commit of that checkpoint up to date,
    -- otherwise the state and the checkpoints will get out of sync.
    , HistoryConfig -> Maybe Commit
hist_last_commit :: !(Maybe GitT.Commit)
    } deriving (Int -> HistoryConfig -> ShowS
[HistoryConfig] -> ShowS
HistoryConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HistoryConfig] -> ShowS
$cshowList :: [HistoryConfig] -> ShowS
show :: HistoryConfig -> String
$cshow :: HistoryConfig -> String
showsPrec :: Int -> HistoryConfig -> ShowS
$cshowsPrec :: Int -> HistoryConfig -> ShowS
Show)

empty_history_config :: HistoryConfig
empty_history_config :: HistoryConfig
empty_history_config = Int -> Maybe Commit -> HistoryConfig
HistoryConfig Int
Config.default_keep_history forall a. Maybe a
Nothing

data HistoryCollect = HistoryCollect {
    -- | This is cleared after each cmd.  A cmd can cons its name on, and
    -- the cmd is recorded with the (optional) set of names it returns.
    -- Hopefully each cmd has at least one name, since this makes the history
    -- more readable.  There can be more than one name if the history records
    -- several cmds or if one cmd calls another.
    HistoryCollect -> [Text]
state_cmd_names :: ![Text]
    -- | Suppress history record until the EditMode changes from the given one.
    -- This is a bit of a hack so that every keystroke in a raw edit isn't
    -- recorded separately.
    , HistoryCollect -> Maybe EditMode
state_suppress_edit :: !(Maybe EditMode)
    -- | The Git.Commit in the SaveHistory should definitely be Nothing.
    , HistoryCollect -> Maybe SaveHistory
state_suppressed :: !(Maybe SaveGitT.SaveHistory)
    } deriving (Int -> HistoryCollect -> ShowS
[HistoryCollect] -> ShowS
HistoryCollect -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HistoryCollect] -> ShowS
$cshowList :: [HistoryCollect] -> ShowS
show :: HistoryCollect -> String
$cshow :: HistoryCollect -> String
showsPrec :: Int -> HistoryCollect -> ShowS
$cshowsPrec :: Int -> HistoryCollect -> ShowS
Show)

empty_history_collect :: HistoryCollect
empty_history_collect :: HistoryCollect
empty_history_collect = HistoryCollect
    { state_cmd_names :: [Text]
state_cmd_names = []
    , state_suppress_edit :: Maybe EditMode
state_suppress_edit = forall a. Maybe a
Nothing
    , state_suppressed :: Maybe SaveHistory
state_suppressed = forall a. Maybe a
Nothing
    }

data HistoryEntry = HistoryEntry {
    HistoryEntry -> State
hist_state :: !Ui.State
    -- | Since track event updates are not caught by diff but recorded by
    -- Ui.State, I have to save those too, or else an undo or redo will miss
    -- the event changes.  TODO ugly, can I avoid this?
    --
    -- If this HistoryEntry is in the past, these are the updates that took it
    -- to the future, not the updates emitted by the cmd itself.  If the
    -- HistoryEntry is in the future, the updates take it to the past, which
    -- are the updated emitted by the cmd.  So don't be confused if it looks
    -- like a HistoryEntry has the wrong updates.
    , HistoryEntry -> UiDamage
hist_damage :: !Update.UiDamage
    -- | Cmds involved creating this entry.
    , HistoryEntry -> [Text]
hist_names :: ![Text]
    -- | The Commit where this entry was saved.  Nothing if the entry is
    -- unsaved.
    , HistoryEntry -> Maybe Commit
hist_commit :: !(Maybe GitT.Commit)
    } deriving (Int -> HistoryEntry -> ShowS
[HistoryEntry] -> ShowS
HistoryEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HistoryEntry] -> ShowS
$cshowList :: [HistoryEntry] -> ShowS
show :: HistoryEntry -> String
$cshow :: HistoryEntry -> String
showsPrec :: Int -> HistoryEntry -> ShowS
$cshowsPrec :: Int -> HistoryEntry -> ShowS
Show)

empty_history_entry :: Ui.State -> HistoryEntry
empty_history_entry :: State -> HistoryEntry
empty_history_entry State
state = HistoryEntry
    { hist_state :: State
hist_state = State
state
    , hist_damage :: UiDamage
hist_damage = forall a. Monoid a => a
mempty
    , hist_names :: [Text]
hist_names = []
    , hist_commit :: Maybe Commit
hist_commit = forall a. Maybe a
Nothing
    }

instance Pretty History where
    format :: History -> Doc
format (History [HistoryEntry]
past HistoryEntry
present [HistoryEntry]
future Maybe LastCmd
last_cmd) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"History"
        [ (Text
"past", forall a. Pretty a => a -> Doc
Pretty.format [HistoryEntry]
past)
        , (Text
"present", forall a. Pretty a => a -> Doc
Pretty.format HistoryEntry
present)
        , (Text
"future", forall a. Pretty a => a -> Doc
Pretty.format [HistoryEntry]
future)
        , (Text
"last_cmd", Text -> Doc
Pretty.text (forall a. Show a => a -> Text
showt Maybe LastCmd
last_cmd))
        ]

instance Pretty HistoryEntry where
    format :: HistoryEntry -> Doc
format (HistoryEntry State
_state UiDamage
damage [Text]
commands Maybe Commit
commit) =
        forall a. Pretty a => a -> Doc
Pretty.format Maybe Commit
commit Doc -> Doc -> Doc
Pretty.<+> [Text] -> Doc
Pretty.textList [Text]
commands
        Doc -> Doc -> Doc
Pretty.<+> forall a. Pretty a => a -> Doc
Pretty.format UiDamage
damage

instance Pretty HistoryConfig where
    format :: HistoryConfig -> Doc
format (HistoryConfig Int
keep Maybe Commit
last_commit) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"HistoryConfig"
        [ (Text
"keep", forall a. Pretty a => a -> Doc
Pretty.format Int
keep)
        , (Text
"last_commit", forall a. Pretty a => a -> Doc
Pretty.format Maybe Commit
last_commit)
        ]

instance Pretty HistoryCollect where
    format :: HistoryCollect -> Doc
format (HistoryCollect [Text]
names Maybe EditMode
edit Maybe SaveHistory
suppressed) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"HistoryCollect"
            [ (Text
"names", forall a. Pretty a => a -> Doc
Pretty.format [Text]
names)
            , (Text
"suppress_edit", forall a. Pretty a => a -> Doc
Pretty.format Maybe EditMode
edit)
            , (Text
"suppressed", forall a. Pretty a => a -> Doc
Pretty.format Maybe SaveHistory
suppressed)
            ]

-- *** SelectionHistory

-- | Remember previous selections.  This should be updated only by significant
-- movements, so clicks and cmd-a, but not hjkl stuff.
data SelectionHistory = SelectionHistory {
    SelectionHistory -> [(ViewId, Selection)]
sel_past :: [(ViewId, Sel.Selection)]
    , SelectionHistory -> [(ViewId, Selection)]
sel_future :: [(ViewId, Sel.Selection)]
    } deriving (SelectionHistory -> SelectionHistory -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SelectionHistory -> SelectionHistory -> Bool
$c/= :: SelectionHistory -> SelectionHistory -> Bool
== :: SelectionHistory -> SelectionHistory -> Bool
$c== :: SelectionHistory -> SelectionHistory -> Bool
Eq, Int -> SelectionHistory -> ShowS
[SelectionHistory] -> ShowS
SelectionHistory -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SelectionHistory] -> ShowS
$cshowList :: [SelectionHistory] -> ShowS
show :: SelectionHistory -> String
$cshow :: SelectionHistory -> String
showsPrec :: Int -> SelectionHistory -> ShowS
$cshowsPrec :: Int -> SelectionHistory -> ShowS
Show)

empty_selection_history :: SelectionHistory
empty_selection_history :: SelectionHistory
empty_selection_history = [(ViewId, Selection)] -> [(ViewId, Selection)] -> SelectionHistory
SelectionHistory [] []

instance Pretty SelectionHistory where
    format :: SelectionHistory -> Doc
format (SelectionHistory [(ViewId, Selection)]
past [(ViewId, Selection)]
future) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"SelectionHistory"
        [ (Text
"past", forall a. Pretty a => a -> Doc
Pretty.format [(ViewId, Selection)]
past)
        , (Text
"future", forall a. Pretty a => a -> Doc
Pretty.format [(ViewId, Selection)]
future)
        ]

-- *** modifier

data Modifier = KeyMod Key.Modifier
    -- | Mouse button, and track it went down at, if any.  The block is not
    -- recorded.  You can't drag across blocks so you know any click must
    -- apply to the focused block.
    | MouseMod Types.MouseButton (Maybe (TrackNum, UiMsg.Track))
    -- | Only chan and key are stored.  While it may be useful to map according
    -- to the device, this code doesn't know which devices are available.
    -- Block or track level handlers can query the device themselves.
    | MidiMod Midi.Channel Midi.Key
    deriving (Modifier -> Modifier -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Modifier -> Modifier -> Bool
$c/= :: Modifier -> Modifier -> Bool
== :: Modifier -> Modifier -> Bool
$c== :: Modifier -> Modifier -> Bool
Eq, Eq Modifier
Modifier -> Modifier -> Bool
Modifier -> Modifier -> Ordering
Modifier -> Modifier -> Modifier
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 :: Modifier -> Modifier -> Modifier
$cmin :: Modifier -> Modifier -> Modifier
max :: Modifier -> Modifier -> Modifier
$cmax :: Modifier -> Modifier -> Modifier
>= :: Modifier -> Modifier -> Bool
$c>= :: Modifier -> Modifier -> Bool
> :: Modifier -> Modifier -> Bool
$c> :: Modifier -> Modifier -> Bool
<= :: Modifier -> Modifier -> Bool
$c<= :: Modifier -> Modifier -> Bool
< :: Modifier -> Modifier -> Bool
$c< :: Modifier -> Modifier -> Bool
compare :: Modifier -> Modifier -> Ordering
$ccompare :: Modifier -> Modifier -> Ordering
Ord, Int -> Modifier -> ShowS
[Modifier] -> ShowS
Modifier -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Modifier] -> ShowS
$cshowList :: [Modifier] -> ShowS
show :: Modifier -> String
$cshow :: Modifier -> String
showsPrec :: Int -> Modifier -> ShowS
$cshowsPrec :: Int -> Modifier -> ShowS
Show, ReadPrec [Modifier]
ReadPrec Modifier
Int -> ReadS Modifier
ReadS [Modifier]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Modifier]
$creadListPrec :: ReadPrec [Modifier]
readPrec :: ReadPrec Modifier
$creadPrec :: ReadPrec Modifier
readList :: ReadS [Modifier]
$creadList :: ReadS [Modifier]
readsPrec :: Int -> ReadS Modifier
$creadsPrec :: Int -> ReadS Modifier
Read)

instance Pretty Modifier where
    pretty :: Modifier -> Text
pretty = \case
        KeyMod Modifier
mod -> forall a. Pretty a => a -> Text
pretty Modifier
mod
        MouseMod Int
button Maybe (Int, Track)
mb_track -> Text
"MouseMod" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Int
button, Maybe (Int, Track)
mb_track)
        MidiMod Channel
chan Key
key -> Text
"MidiMod" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Channel
chan, Key
key)

mouse_mod_btn :: Modifier -> Maybe Types.MouseButton
mouse_mod_btn :: Modifier -> Maybe Int
mouse_mod_btn (MouseMod Int
btn Maybe (Int, Track)
_) = forall a. a -> Maybe a
Just Int
btn
mouse_mod_btn Modifier
_ = forall a. Maybe a
Nothing


-- | Take a modifier to its key in the modifier map which has extra info like
-- mouse down position stripped.
strip_modifier :: Modifier -> Modifier
strip_modifier :: Modifier -> Modifier
strip_modifier (MouseMod Int
btn Maybe (Int, Track)
_) = Int -> Maybe (Int, Track) -> Modifier
MouseMod Int
btn forall a. Maybe a
Nothing
strip_modifier Modifier
mod = Modifier
mod


-- ** state access

gets :: M m => (State -> a) -> m a
gets :: forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> a
f = do
    State
state <- forall (m :: * -> *). M m => m State
get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! State -> a
f State
state

modify :: M m => (State -> State) -> m ()
modify :: forall (m :: * -> *). M m => (State -> State) -> m ()
modify State -> State
f = do
    State
st <- forall (m :: * -> *). M m => m State
get
    forall (m :: * -> *). M m => State -> m ()
put forall a b. (a -> b) -> a -> b
$! State -> State
f State
st

modify_play_state :: M m => (PlayState -> PlayState) -> m ()
modify_play_state :: forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
modify_play_state PlayState -> PlayState
f = forall (m :: * -> *). M m => (State -> State) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_play :: PlayState
state_play = PlayState -> PlayState
f (State -> PlayState
state_play State
st) }

-- | Return the rect of the screen closest to the given point, or the default.
get_screen :: M m => Maybe (Int, Int) -> m Rect.Rect
get_screen :: forall (m :: * -> *). M m => Maybe (Int, Int) -> m Rect
get_screen Maybe (Int, Int)
mb_point = do
    [Rect]
screens <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> [Rect]
state_screens
    -- There are no screens yet during setup, so pick something somewhat
    -- reasonable so windows don't all try to crunch themselves down to
    -- nothing.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Int -> Int -> Rect
Rect.xywh Int
0 Int
0 Int
800 Int
600) forall a b. (a -> b) -> a -> b
$ case Maybe (Int, Int)
mb_point of
        Maybe (Int, Int)
Nothing -> forall a. [a] -> Maybe a
Lists.head [Rect]
screens
        Just (Int, Int)
point -> forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn ((Int, Int) -> Rect -> Double
Rect.distance (Int, Int)
point) [Rect]
screens

lookup_performance :: M m => BlockId -> m (Maybe Performance)
lookup_performance :: forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
lookup_performance BlockId
block_id =
    forall (m :: * -> *) a. M m => (State -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Map BlockId Performance
state_performance forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
state_play

get_performance :: M m => BlockId -> m Performance
get_performance :: forall (m :: * -> *). M m => BlockId -> m Performance
get_performance BlockId
block_id = forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
lookup_performance BlockId
block_id

-- | Clear all performances, which will cause them to be rederived.
-- This is stronger than 'Ui.update_all', because Ui.update_all will simply
-- cause diff to look at the blocks for diffs, while this will force a
-- re-derivation even if there are no apparent diffs.
invalidate_performances :: M m => m ()
invalidate_performances :: forall (m :: * -> *). M m => m ()
invalidate_performances = forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
state -> PlayState
state
    { state_performance :: Map BlockId Performance
state_performance = forall a. Monoid a => a
mempty
    , state_current_performance :: Map BlockId Performance
state_current_performance = forall a. Monoid a => a
mempty
    }

clear_im_cache :: BlockId -> CmdT IO ()
clear_im_cache :: BlockId -> CmdT IO ()
clear_im_cache BlockId
block_id = do
    String
path <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> String
score_path
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Config
config <- IO Config
Shared.Config.getConfig
        let imDir :: String
imDir = Config -> String
Shared.Config.imDir Config
config
        forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$
            String -> String -> BlockId -> String
Shared.Config.notesDirectory String
imDir String
path BlockId
block_id
        forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$
            String -> String -> BlockId -> String
Shared.Config.outputDirectory String
imDir String
path BlockId
block_id
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Keys currently held down, as in 'state_keys_down'.
keys_down :: M m => m (Map Modifier Modifier)
keys_down :: forall (m :: * -> *). M m => m (Map Modifier Modifier)
keys_down = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map Modifier Modifier
state_keys_down

get_focused_view :: M m => m ViewId
get_focused_view :: forall (m :: * -> *). M m => m ViewId
get_focused_view = forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Maybe ViewId
state_focused_view

get_focused_block :: M m => m BlockId
get_focused_block :: forall (m :: * -> *). M m => m BlockId
get_focused_block = View -> BlockId
Block.view_block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m ViewId
get_focused_view)

lookup_focused_view :: M m => m (Maybe ViewId)
lookup_focused_view :: forall (m :: * -> *). M m => m (Maybe ViewId)
lookup_focused_view = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Maybe ViewId
state_focused_view

-- | In some circumstances I don't want to abort if there's no focused block.
lookup_focused_block :: M m => m (Maybe BlockId)
lookup_focused_block :: forall (m :: * -> *). M m => m (Maybe BlockId)
lookup_focused_block = do
    Maybe ViewId
maybe_view_id <- forall (m :: * -> *). M m => m (Maybe ViewId)
lookup_focused_view
    case Maybe ViewId
maybe_view_id of
        -- It's still an error if the view id doesn't exist.
        Just ViewId
view_id -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block) (forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id)
        Maybe ViewId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Request focus.  'state_focused_view' will be updated once fltk reports the
-- focus change.
focus :: Ui.M m => ViewId -> m ()
focus :: forall (m :: * -> *). M m => ViewId -> m ()
focus ViewId
view_id = do
    Maybe View
view <- forall (m :: * -> *). M m => ViewId -> m (Maybe View)
Ui.lookup_view ViewId
view_id
    case Maybe View
view of
        Maybe View
Nothing ->
            forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw forall a b. (a -> b) -> a -> b
$ Text
"Cmd.focus on non-existent view: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt ViewId
view_id
        Maybe View
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty { _bring_to_front :: Set ViewId
Update._bring_to_front = forall a. a -> Set a
Set.singleton ViewId
view_id }

get_current_step :: M m => m TimeStep.TimeStep
get_current_step :: forall (m :: * -> *). M m => m TimeStep
get_current_step = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (EditState -> TimeStep
state_time_step forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
state_edit)

-- | Get the leftmost track covered by the insert selection, which is
-- considered the "focused" track by convention.
get_insert_tracknum :: M m => m (Maybe TrackNum)
get_insert_tracknum :: forall (m :: * -> *). M m => m (Maybe Int)
get_insert_tracknum = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
get_focused_view
    Maybe Selection
sel <- forall (m :: * -> *). M m => ViewId -> Int -> m (Maybe Selection)
Ui.get_selection ViewId
view_id Int
Config.insert_selnum
    -- Selection.shift can put the selection on or before the ruler track, so
    -- it doesn't get squished by going off the edge, but I don't want to ever
    -- act like <=0 is selected.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection -> Int
Sel.start_track forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Selection
sel

-- *** status

-- | This just calls 'Ui.set_view_status', but all status setting should
-- go through here so they can be uniformly filtered or logged or something.
set_view_status :: M m => ViewId -> (Int, Text) -> Maybe Text -> m ()
set_view_status :: forall (m :: * -> *).
M m =>
ViewId -> (Int, Text) -> Maybe Text -> m ()
set_view_status = forall (m :: * -> *).
M m =>
ViewId -> (Int, Text) -> Maybe Text -> m ()
Ui.set_view_status

-- | Emit a special log msg that will cause log view to put this key and value
-- in its status bar.  A value of \"\" will cause logview to delete that key.
set_global_status :: M m => Text -> Text -> m ()
set_global_status :: forall (m :: * -> *). M m => Text -> Text -> m ()
set_global_status Text
key Text
val = do
    Map Text Text
status_map <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map Text Text
state_global_status
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text Text
status_map forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Text
val) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). M m => (State -> State) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
st ->
            State
st { state_global_status :: Map Text Text
state_global_status = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key Text
val Map Text Text
status_map }
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"global status: " forall a. Semigroup a => a -> a -> a
<> Text
key forall a. Semigroup a => a -> a -> a
<> Text
" -- " forall a. Semigroup a => a -> a -> a
<> Text
val

-- | Set a status variable on all views.
set_status :: M m => (Int, Text) -> Maybe Text -> m ()
set_status :: forall (m :: * -> *). M m => (Int, Text) -> Maybe Text -> m ()
set_status (Int, Text)
key Maybe Text
val = do
    [ViewId]
view_ids <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$ \ViewId
view_id -> forall (m :: * -> *).
M m =>
ViewId -> (Int, Text) -> Maybe Text -> m ()
set_view_status ViewId
view_id (Int, Text)
key Maybe Text
val

-- ** lookup instrument

-- | This is an instrument as looked up by 'lookup_instrument' or
-- 'get_lookup_instrument'.  This merges compiled-in and runtime instrument
-- data.
data ResolvedInstrument = ResolvedInstrument {
    ResolvedInstrument -> Inst
inst_instrument :: !Inst
    , ResolvedInstrument -> Qualified
inst_qualified :: !InstT.Qualified
    , ResolvedInstrument -> Config
inst_common_config :: !Common.Config
    , ResolvedInstrument -> Backend
inst_backend :: !Backend
    } deriving (Int -> ResolvedInstrument -> ShowS
[ResolvedInstrument] -> ShowS
ResolvedInstrument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResolvedInstrument] -> ShowS
$cshowList :: [ResolvedInstrument] -> ShowS
show :: ResolvedInstrument -> String
$cshow :: ResolvedInstrument -> String
showsPrec :: Int -> ResolvedInstrument -> ShowS
$cshowsPrec :: Int -> ResolvedInstrument -> ShowS
Show)

inst_synth :: ResolvedInstrument -> InstT.SynthName
inst_synth :: ResolvedInstrument -> Text
inst_synth  = Qualified -> Text
InstT.synth forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Qualified
inst_qualified

inst_common :: ResolvedInstrument -> Common.Common InstrumentCode
inst_common :: ResolvedInstrument -> Common InstrumentCode
inst_common = forall code. Inst code -> Common code
Inst.inst_common forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Inst
inst_instrument

instance Pretty ResolvedInstrument where
    format :: ResolvedInstrument -> Doc
format (ResolvedInstrument Inst
instrument Qualified
qualified Config
common_config Backend
backend) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"ResolvedInstrument"
            [ (Text
"instrument", forall a. Pretty a => a -> Doc
Pretty.format Inst
instrument)
            , (Text
"qualified", forall a. Pretty a => a -> Doc
Pretty.format Qualified
qualified)
            , (Text
"common_config", forall a. Pretty a => a -> Doc
Pretty.format Config
common_config)
            , (Text
"backend", forall a. Pretty a => a -> Doc
Pretty.format Backend
backend)
            ]

-- | This merges the compiled-id 'Inst.Backend' and the per-score
-- 'UiConfig.Backend'.
data Backend =
    Midi !Midi.Patch.Patch !Midi.Patch.Config
    | Im !Im.Patch.Patch
    | Sc !Sc.Patch.Patch
    | Dummy !Text
    deriving (Int -> Backend -> ShowS
[Backend] -> ShowS
Backend -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Backend] -> ShowS
$cshowList :: [Backend] -> ShowS
show :: Backend -> String
$cshow :: Backend -> String
showsPrec :: Int -> Backend -> ShowS
$cshowsPrec :: Int -> Backend -> ShowS
Show)

instance Pretty Backend where
    format :: Backend -> Doc
format (Midi Patch
patch Config
config) = forall a. Pretty a => a -> Doc
Pretty.format (Patch
patch, Config
config)
    format (Im Patch
patch) = forall a. Pretty a => a -> Doc
Pretty.format Patch
patch
    format (Sc Patch
patch) = forall a. Pretty a => a -> Doc
Pretty.format Patch
patch
    format (Dummy Text
msg) = Doc
"Dummy \"" forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text Text
msg forall a. Semigroup a => a -> a -> a
<> Doc
"\""

midi_patch :: ResolvedInstrument -> Maybe (Patch.Patch, Patch.Config)
midi_patch :: ResolvedInstrument -> Maybe (Patch, Config)
midi_patch ResolvedInstrument
inst = case ResolvedInstrument -> Backend
inst_backend ResolvedInstrument
inst of
    Midi Patch
patch Config
config -> forall a. a -> Maybe a
Just (Patch
patch, Config
config)
    Backend
_ -> forall a. Maybe a
Nothing

sc_patch :: ResolvedInstrument -> Maybe Sc.Patch.Patch
sc_patch :: ResolvedInstrument -> Maybe Patch
sc_patch ResolvedInstrument
inst = case ResolvedInstrument -> Backend
inst_backend ResolvedInstrument
inst of
    Sc Patch
patch -> forall a. a -> Maybe a
Just Patch
patch
    Backend
_ -> forall a. Maybe a
Nothing

get_midi_instrument :: (CallStack.Stack, M m) => ScoreT.Instrument
    -> m (Patch.Patch, Patch.Config)
get_midi_instrument :: forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
get_midi_instrument Instrument
inst =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"not a midi instrument: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Maybe (Patch, Config)
midi_patch
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m ResolvedInstrument
get_instrument Instrument
inst

lookup_midi_config :: M m => ScoreT.Instrument -> m (Maybe Patch.Config)
lookup_midi_config :: forall (m :: * -> *). M m => Instrument -> m (Maybe Config)
lookup_midi_config Instrument
inst = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *). M m => Instrument -> m (Maybe Backend)
lookup_backend Instrument
inst) forall a b. (a -> b) -> a -> b
$ \case
    Midi Patch
_ Config
config -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Config
config
    Backend
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

lookup_backend :: M m => ScoreT.Instrument -> m (Maybe Backend)
lookup_backend :: forall (m :: * -> *). M m => Instrument -> m (Maybe Backend)
lookup_backend Instrument
inst = forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
lookup_instrument Instrument
inst) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Backend
inst_backend

lookup_instrument :: M m => ScoreT.Instrument -> m (Maybe ResolvedInstrument)
lookup_instrument :: forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
lookup_instrument Instrument
inst = do
    State
ui_state <- forall (m :: * -> *). M m => m State
Ui.get
    InstrumentDb
db <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ Config -> InstrumentDb
config_instrument_db forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
state_config
    case Instrument -> Lens State (Maybe Allocation)
Ui.allocation Instrument
inst forall f a. Lens f a -> f -> a
#$ State
ui_state of
        Maybe Allocation
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just Allocation
alloc -> case InstrumentDb -> Allocation -> Either Text ResolvedInstrument
resolve_instrument InstrumentDb
db Allocation
alloc of
            Left Text
err -> do
                -- This is a broken allocation, so I should log it at least.
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"lookup " 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
err
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Right ResolvedInstrument
val -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ResolvedInstrument
val)

get_instrument :: (CallStack.Stack, M m) => ScoreT.Instrument
    -> m ResolvedInstrument
get_instrument :: forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m ResolvedInstrument
get_instrument Instrument
inst = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"instrument not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
lookup_instrument Instrument
inst

get_lookup_instrument :: M m
    => m (ScoreT.Instrument -> Maybe ResolvedInstrument)
get_lookup_instrument :: forall (m :: * -> *).
M m =>
m (Instrument -> Maybe ResolvedInstrument)
get_lookup_instrument = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just .) forall a b. (a -> b) -> a -> b
$
    State -> State -> Instrument -> Either Text ResolvedInstrument
state_lookup_instrument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m State
Ui.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). M m => m State
get
    -- This throws away the Left error just because that's what its callers all
    -- happen to want.

state_lookup_instrument :: Ui.State -> State -> ScoreT.Instrument
    -> Either Text ResolvedInstrument
state_lookup_instrument :: State -> State -> Instrument -> Either Text ResolvedInstrument
state_lookup_instrument State
ui_state State
cmd_state = Allocations
-> InstrumentDb -> Instrument -> Either Text ResolvedInstrument
memoized_instrument
    (Config -> Allocations
UiConfig.config_allocations (State -> Config
Ui.state_config State
ui_state))
    (Config -> InstrumentDb
config_instrument_db (State -> Config
state_config State
cmd_state))

-- | This memoizes instrument resolution in case you're going to do it a lot.
-- 'resolve_instrument' has to merge some things so it's not exactly free.
-- The spine-strict Map makes this less efficient for one-off lookups, but so
-- far all uses are mapping the lookup across many events.
--
-- Of course, the memoization only works as long as the memo table persists,
-- which should happen if you use 'get_lookup_instrument' and reuse the
-- function it returns.
memoized_instrument :: UiConfig.Allocations -> InstrumentDb
    -> ScoreT.Instrument -> Either Text ResolvedInstrument
memoized_instrument :: Allocations
-> InstrumentDb -> Instrument -> Either Text ResolvedInstrument
memoized_instrument (UiConfig.Allocations Map Instrument Allocation
allocs) InstrumentDb
db = \Instrument
inst ->
    forall a. a -> Maybe a -> a
fromMaybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"no alloc for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst Map Instrument (Either Text ResolvedInstrument)
memo
    where
    memo :: Map Instrument (Either Text ResolvedInstrument)
memo = Allocation -> Either Text ResolvedInstrument
resolve forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Instrument Allocation
allocs
    resolve :: Allocation -> Either Text ResolvedInstrument
resolve Allocation
alloc = InstrumentDb -> Allocation -> Either Text ResolvedInstrument
resolve_instrument InstrumentDb
db Allocation
alloc

-- | See 'ResolvedInstrument'.
resolve_instrument :: InstrumentDb -> UiConfig.Allocation
    -> Either Text ResolvedInstrument
resolve_instrument :: InstrumentDb -> Allocation -> Either Text ResolvedInstrument
resolve_instrument InstrumentDb
db Allocation
alloc = do
    let qualified :: Qualified
qualified = Allocation -> Qualified
UiConfig.alloc_qualified Allocation
alloc
    Inst
inst <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"patch not in db: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Qualified
qualified) forall a b. (a -> b) -> a -> b
$
        Qualified -> InstrumentDb -> Maybe Inst
inst_lookup Qualified
qualified InstrumentDb
db
    Backend
backend <- case (forall code. Inst code -> Backend
Inst.inst_backend Inst
inst, Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc) of
        (Inst.Midi Patch
patch, UiConfig.Midi Config
config) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Patch -> Config -> Backend
Midi Patch
patch (Patch -> Config -> Config
Patch.merge_defaults Patch
patch Config
config)
        (Inst.Im Patch
patch, Backend
UiConfig.Im) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Patch -> Backend
Im Patch
patch
        (Inst.Sc Patch
patch, Backend
UiConfig.Sc) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Patch -> Backend
Sc Patch
patch
        (Inst.Dummy Text
msg1, UiConfig.Dummy Text
msg2) ->
            -- If it's a dummy allocation of a dummy patch, then I can use ""
            -- to use the patch's msg.
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Backend
Dummy forall a b. (a -> b) -> a -> b
$ if Text
msg2 forall a. Eq a => a -> a -> Bool
/= Text
"" then Text
msg2 else Text
msg1
        -- 'UiConfig.verify_allocation' should have prevented this.
        (Backend
inst_backend, Backend
alloc_backend) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            Text
"inconsistent backends: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Backend
inst_backend, Backend
alloc_backend)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResolvedInstrument
        { inst_instrument :: Inst
inst_instrument = Inst
inst -- merge_call_map backend inst
        , inst_qualified :: Qualified
inst_qualified = Qualified
qualified
        , inst_common_config :: Config
inst_common_config =
            Common InstrumentCode -> Config -> Config
merge_environ (forall code. Inst code -> Common code
Inst.inst_common Inst
inst) (Allocation -> Config
UiConfig.alloc_config Allocation
alloc)
        , inst_backend :: Backend
inst_backend = Backend
backend
        }
    where
    -- Merge instrument default environ with the local Allocation.
    -- I used to use Maybe and replace when it was Just, but it turns out
    -- I definitely want to merge things like inst-top and inst-bottom.
    -- This means I can't delete keys, but if I ever need that I could
    -- do something like map to NotGiven.
    merge_environ :: Common.Common InstrumentCode -> Common.Config
        -> Common.Config
    merge_environ :: Common InstrumentCode -> Config -> Config
merge_environ Common InstrumentCode
common = Config :-> Environ
Common.cenviron forall f a. Lens f a -> (a -> a) -> f -> f
%= (forall code. Common code -> Environ
Common.common_environ Common InstrumentCode
common <>)

    -- TODO: I'm not sure if I want this or not... now Convert converts all
    -- attrs, while this had the effect of only converting supported ones.
    -- Which seems generally nice, so I'll leave the code here.
    -- Put the attrs the instrument understands in the CallMap as +attr calls.
    -- If there isn't already a higher level call in there, then at least we
    -- don't lose the attrs entirely.
    merge_call_map :: Backend -> Inst code -> Inst code
merge_call_map Backend
backend =
        forall {code}. Inst code :-> Common code
Inst.commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> CallMap
Common.call_map forall f a. Lens f a -> (a -> a) -> f -> f
%= (forall a. Semigroup a => a -> a -> a
<> forall {a}. (Ord a, Monoid a, ShowVal a) => [a] -> Map a Symbol
attr_calls (Backend -> [Attributes]
inst_attrs Backend
backend))
    attr_calls :: [a] -> Map a Symbol
attr_calls [a]
attrs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (a
attr, Text -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Text
ShowVal.show_val a
attr)
        | a
attr <- [a]
attrs, a
attr forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty
        ]
    inst_attrs :: Backend -> [Attributes]
inst_attrs = \case
        Midi Patch
patch Config
_ ->
            forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes forall a b. (a -> b) -> a -> b
$ Patch -> AttributeMap
Midi.Patch.patch_attribute_map Patch
patch
        Im Patch
patch ->
            forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes forall a b. (a -> b) -> a -> b
$ Patch -> AttributeMap
Im.Patch.patch_attribute_map Patch
patch
        Sc Patch
_patch -> forall a. Monoid a => a
mempty -- TODO attrs for sc?
        Dummy {} -> forall a. Monoid a => a
mempty

-- ** lookup qualified name

get_qualified :: M m => InstT.Qualified -> m Inst
get_qualified :: forall (m :: * -> *). M m => Qualified -> m Inst
get_qualified Qualified
qualified =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"patch not in db: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Qualified
qualified)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Qualified -> m (Maybe Inst)
lookup_qualified Qualified
qualified

get_alloc_qualified :: M m => UiConfig.Allocation -> m Inst
get_alloc_qualified :: forall (m :: * -> *). M m => Allocation -> m Inst
get_alloc_qualified = forall (m :: * -> *). M m => Qualified -> m Inst
get_qualified forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocation -> Qualified
UiConfig.alloc_qualified

-- | Look up an instrument that might not be allocated.
lookup_qualified :: M m => InstT.Qualified -> m (Maybe Inst)
lookup_qualified :: forall (m :: * -> *). M m => Qualified -> m (Maybe Inst)
lookup_qualified Qualified
qualified = do
    Config
config <- forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Config
state_config
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Qualified -> InstrumentDb -> Maybe Inst
inst_lookup Qualified
qualified (Config -> InstrumentDb
config_instrument_db Config
config)

get_lookup_backend :: State -> InstT.Qualified -> Maybe Inst.Backend
get_lookup_backend :: State -> Qualified -> Maybe Backend
get_lookup_backend State
state Qualified
qualified = forall code. Inst code -> Backend
Inst.inst_backend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Qualified -> InstrumentDb -> Maybe Inst
inst_lookup Qualified
qualified (Config -> InstrumentDb
config_instrument_db (State -> Config
state_config State
state))

inst_lookup :: InstT.Qualified -> InstrumentDb -> Maybe Inst
inst_lookup :: Qualified -> InstrumentDb -> Maybe Inst
inst_lookup Qualified
qualified InstrumentDb
db
    | Qualified
qualified forall a. Eq a => a -> a -> Bool
== Qualified
InstT.dummy =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall code. Backend -> Common code -> Inst code
Inst.Inst (Text -> Backend
Inst.Dummy Text
"") (forall code. code -> Common code
Common.common InstrumentCode
empty_code)
    | Bool
otherwise = forall code. Qualified -> Db code -> Maybe (Inst code)
Inst.lookup Qualified
qualified InstrumentDb
db

-- ** misc

get_wdev_state :: M m => m WriteDeviceState
get_wdev_state :: forall (m :: * -> *). M m => m WriteDeviceState
get_wdev_state = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> WriteDeviceState
state_wdev_state

modify_wdev_state :: M m => (WriteDeviceState -> WriteDeviceState) -> m ()
modify_wdev_state :: forall (m :: * -> *).
M m =>
(WriteDeviceState -> WriteDeviceState) -> m ()
modify_wdev_state WriteDeviceState -> WriteDeviceState
f = forall (m :: * -> *). M m => (State -> State) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
st ->
    State
st { state_wdev_state :: WriteDeviceState
state_wdev_state = WriteDeviceState -> WriteDeviceState
f (State -> WriteDeviceState
state_wdev_state State
st) }

derive_immediately :: M m => [BlockId] -> m ()
derive_immediately :: forall (m :: * -> *). M m => [BlockId] -> m ()
derive_immediately [BlockId]
block_ids = forall (m :: * -> *). M m => (State -> State) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_derive_immediately :: Set BlockId
state_derive_immediately =
    forall a. Ord a => [a] -> Set a
Set.fromList [BlockId]
block_ids forall a. Semigroup a => a -> a -> a
<> State -> Set BlockId
state_derive_immediately State
st }

inflict_damage :: M m => Derive.ScoreDamage -> m ()
inflict_damage :: forall (m :: * -> *). M m => ScoreDamage -> m ()
inflict_damage ScoreDamage
damage = forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
modify_play_state forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
    { state_current_performance :: Map BlockId Performance
state_current_performance = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Performance -> Performance
inflict (PlayState -> Map BlockId Performance
state_current_performance PlayState
st)
    }
    where inflict :: Performance -> Performance
inflict Performance
perf = Performance
perf { perf_damage :: ScoreDamage
perf_damage = ScoreDamage
damage forall a. Semigroup a => a -> a -> a
<> Performance -> ScoreDamage
perf_damage Performance
perf }

-- | Cause a block to rederive even if there haven't been any edits on it.
inflict_block_damage :: M m => BlockId -> m ()
inflict_block_damage :: forall (m :: * -> *). M m => BlockId -> m ()
inflict_block_damage BlockId
block_id = forall (m :: * -> *). M m => ScoreDamage -> m ()
inflict_damage forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
    { sdamage_blocks :: Set BlockId
Derive.sdamage_blocks = forall a. a -> Set a
Set.singleton BlockId
block_id }

-- | Cause a track to rederive even if there haven't been any edits on it.
inflict_track_damage :: M m => BlockId -> TrackId -> m ()
inflict_track_damage :: forall (m :: * -> *). M m => BlockId -> TrackId -> m ()
inflict_track_damage BlockId
block_id TrackId
track_id = forall (m :: * -> *). M m => ScoreDamage -> m ()
inflict_damage forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
    { sdamage_tracks :: Map TrackId (Ranges ScoreTime)
Derive.sdamage_tracks = forall k a. k -> a -> Map k a
Map.singleton TrackId
track_id forall n. Ranges n
Ranges.everything
    , sdamage_track_blocks :: Set BlockId
Derive.sdamage_track_blocks = forall a. a -> Set a
Set.singleton BlockId
block_id
    }

-- ** EditState

modify_edit_state :: M m => (EditState -> EditState) -> m ()
modify_edit_state :: forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state EditState -> EditState
f = forall (m :: * -> *). M m => (State -> State) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_edit :: EditState
state_edit = EditState -> EditState
f (State -> EditState
state_edit State
st) }

-- | At the Ui level, the edit box is per-block, but I use it to indicate edit
-- mode, which is global.  So it gets stored in Cmd.State and must be synced
-- with new blocks.
set_edit_box :: M m => Block.Box -> Block.Box -> m ()
set_edit_box :: forall (m :: * -> *). M m => Box -> Box -> m ()
set_edit_box Box
skel Box
track = do
    forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st { state_edit_box :: (Box, Box)
state_edit_box = (Box
skel, Box
track) }
    [BlockId]
block_ids <- forall (m :: * -> *). M m => m [BlockId]
Ui.all_block_ids
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BlockId]
block_ids forall a b. (a -> b) -> a -> b
$ \BlockId
bid -> forall (m :: * -> *). M m => BlockId -> Box -> Box -> m ()
Ui.set_edit_box BlockId
bid Box
skel Box
track

is_val_edit :: M m => m Bool
is_val_edit :: forall (m :: * -> *). M m => m Bool
is_val_edit = (forall a. Eq a => a -> a -> Bool
== EditMode
ValEdit) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (EditState -> EditMode
state_edit_mode forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
state_edit)

is_kbd_entry :: M m => m Bool
is_kbd_entry :: forall (m :: * -> *). M m => m Bool
is_kbd_entry = forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (EditState -> Bool
state_kbd_entry forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
state_edit)

set_note_text :: M m => Text -> m ()
set_note_text :: forall (m :: * -> *). M m => Text -> m ()
set_note_text Text
text = do
    forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st { state_note_text :: Text
state_note_text = Text
text }
    forall (m :: * -> *). M m => (Int, Text) -> Maybe Text -> m ()
set_status (Int, Text)
Config.status_note_text forall a b. (a -> b) -> a -> b
$
        if Text -> Bool
Text.null Text
text then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Text
text

get_instrument_attributes :: M m => ScoreT.Instrument -> m Attrs.Attributes
get_instrument_attributes :: forall (m :: * -> *). M m => Instrument -> m Attributes
get_instrument_attributes Instrument
inst = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditState -> Map Instrument Attributes
state_instrument_attributes forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
state_edit)

set_instrument_attributes :: M m => ScoreT.Instrument -> Attrs.Attributes
    -> m ()
set_instrument_attributes :: forall (m :: * -> *). M m => Instrument -> Attributes -> m ()
set_instrument_attributes Instrument
inst Attributes
attrs = forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st
    { state_instrument_attributes :: Map Instrument Attributes
state_instrument_attributes =
        forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Instrument
inst Attributes
attrs (EditState -> Map Instrument Attributes
state_instrument_attributes EditState
st)
    }


-- * util

-- | Give a name to a Cmd.  The name is applied when the cmd returns so the
-- names come out in call order, and it doesn't incur overhead for cmds that
-- abort.
name :: M m => Text -> m a -> m a
name :: forall (m :: * -> *) a. M m => Text -> m a -> m a
name Text
s m a
cmd = m a
cmd forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). M m => (State -> State) -> m ()
modify (\State
st -> State
st
    { state_history_collect :: HistoryCollect
state_history_collect = (State -> HistoryCollect
state_history_collect State
st)
        { state_cmd_names :: [Text]
state_cmd_names = Text
s forall a. a -> [a] -> [a]
: HistoryCollect -> [Text]
state_cmd_names (State -> HistoryCollect
state_history_collect State
st) }
    })

-- | Like 'name', but also set the 'state_suppress_edit'.  This will suppress
-- history recording until the edit mode changes from the given one.
suppress_history :: M m => EditMode -> Text -> m a -> m a
suppress_history :: forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a
suppress_history EditMode
mode Text
name m a
cmd = m a
cmd forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). M m => (State -> State) -> m ()
modify (\State
st -> State
st
    { state_history_collect :: HistoryCollect
state_history_collect = (State -> HistoryCollect
state_history_collect State
st)
        { state_cmd_names :: [Text]
state_cmd_names = Text
name forall a. a -> [a] -> [a]
: HistoryCollect -> [Text]
state_cmd_names (State -> HistoryCollect
state_history_collect State
st)
        , state_suppress_edit :: Maybe EditMode
state_suppress_edit = forall a. a -> Maybe a
Just EditMode
mode
        }
    })

-- | Log an event so that it can be clicked on in logview.
log_event :: BlockId -> TrackId -> Event.Event -> Text
log_event :: BlockId -> TrackId -> Event -> Text
log_event BlockId
block_id TrackId
track_id Event
event =
    UiFrame -> Text
Stack.log_ui_frame (forall a. a -> Maybe a
Just BlockId
block_id, forall a. a -> Maybe a
Just TrackId
track_id, forall a. a -> Maybe a
Just (Event -> (ScoreTime, ScoreTime)
Event.range Event
event))

-- | Turn off all sounding notes, reset controls.
-- TODO clear out WriteDeviceState?
all_notes_off :: M m => m ()
all_notes_off :: forall (m :: * -> *). M m => m ()
all_notes_off = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Thru -> m ()
write_thru
    [ Message -> Thru
MidiThru forall a b. (a -> b) -> a -> b
$ RealTime -> Message
Midi.Interface.AllNotesOff RealTime
0
    , Message -> Thru
MidiThru forall a b. (a -> b) -> a -> b
$ RealTime -> Message
Interface.reset_controls RealTime
0
    , Message -> Thru
ImThru Message
Thru.Stop
    ]