-- 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.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.Seq as Seq

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 = Maybe (NoteEntryMap Text) -> NamedCmd m -> Handler m
forall (m :: * -> *).
Maybe (NoteEntryMap Text) -> NamedCmd m -> Handler m
Handler Maybe (NoteEntryMap Text)
forall a. Maybe a
Nothing (Text -> (Msg -> m Status) -> NamedCmd m
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
            Text -> m ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"running command: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
            Text -> m Status -> m Status
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 -> NamedCmd m -> m Status
forall {m :: * -> *}. M m => NamedCmd m -> m Status
run NamedCmd m
cmd
        Keymap Keymap m
keymap -> do
            Bindable
bindable <- Maybe Bindable -> m Bindable
forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless (Msg -> Maybe Bindable
msg_to_bindable Msg
msg)
            Set Modifier
mods <- m (Set Modifier)
forall (m :: * -> *). M m => m (Set Modifier)
mods_down
            m Status
-> (NamedCmd m -> m Status) -> Maybe (NamedCmd m) -> m Status
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Status -> m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Continue) NamedCmd m -> m Status
forall {m :: * -> *}. M m => NamedCmd m -> m Status
run (Maybe (NamedCmd m) -> m Status) -> Maybe (NamedCmd m) -> m Status
forall a b. (a -> b) -> a -> b
$
                KeySpec -> Keymap m -> Maybe (NamedCmd m)
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 = [Modifier] -> Set Modifier
forall a. Ord a => [a] -> Set a
Set.fromList ([Modifier] -> Set Modifier) -> m [Modifier] -> m (Set Modifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Modifier Modifier -> [Modifier])
-> m (Map Modifier Modifier) -> m [Modifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Modifier -> Bool) -> [Modifier] -> [Modifier]
forall a. (a -> Bool) -> [a] -> [a]
filter Modifier -> Bool
is_mod ([Modifier] -> [Modifier])
-> (Map Modifier Modifier -> [Modifier])
-> Map Modifier Modifier
-> [Modifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Modifier Modifier -> [Modifier]
forall k a. Map k a -> [k]
Map.keys) m (Map Modifier Modifier)
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
[NoteEntryMap a] -> ShowS
NoteEntryMap a -> String
(Int -> NoteEntryMap a -> ShowS)
-> (NoteEntryMap a -> String)
-> ([NoteEntryMap a] -> ShowS)
-> Show (NoteEntryMap a)
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 -> b) -> NoteEntryMap a -> NoteEntryMap b)
-> (forall a b. a -> NoteEntryMap b -> NoteEntryMap a)
-> Functor NoteEntryMap
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 -> Char -> Map Char a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
char (Map Char a -> Maybe a) -> Maybe (Map Char a) -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Map Int (Map Char a) -> Maybe (Map Char a)
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 -> Char -> Map Char a -> Maybe a
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
(KeySpec -> KeySpec -> Bool)
-> (KeySpec -> KeySpec -> Bool) -> Eq KeySpec
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
Eq KeySpec
-> (KeySpec -> KeySpec -> Ordering)
-> (KeySpec -> KeySpec -> Bool)
-> (KeySpec -> KeySpec -> Bool)
-> (KeySpec -> KeySpec -> Bool)
-> (KeySpec -> KeySpec -> Bool)
-> (KeySpec -> KeySpec -> KeySpec)
-> (KeySpec -> KeySpec -> KeySpec)
-> Ord 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
(Int -> KeySpec -> ShowS)
-> (KeySpec -> String) -> ([KeySpec] -> ShowS) -> Show KeySpec
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
(Bindable -> Bindable -> Bool)
-> (Bindable -> Bindable -> Bool) -> Eq Bindable
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
Eq Bindable
-> (Bindable -> Bindable -> Ordering)
-> (Bindable -> Bindable -> Bool)
-> (Bindable -> Bindable -> Bool)
-> (Bindable -> Bindable -> Bool)
-> (Bindable -> Bindable -> Bool)
-> (Bindable -> Bindable -> Bindable)
-> (Bindable -> Bindable -> Bindable)
-> Ord 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
(Int -> Bindable -> ShowS)
-> (Bindable -> String) -> ([Bindable] -> ShowS) -> Show Bindable
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
(MouseOn -> MouseOn -> Bool)
-> (MouseOn -> MouseOn -> Bool) -> Eq MouseOn
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
Eq MouseOn
-> (MouseOn -> MouseOn -> Ordering)
-> (MouseOn -> MouseOn -> Bool)
-> (MouseOn -> MouseOn -> Bool)
-> (MouseOn -> MouseOn -> Bool)
-> (MouseOn -> MouseOn -> Bool)
-> (MouseOn -> MouseOn -> MouseOn)
-> (MouseOn -> MouseOn -> MouseOn)
-> Ord 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
(Int -> MouseOn -> ShowS)
-> (MouseOn -> String) -> ([MouseOn] -> ShowS) -> Show MouseOn
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)) -> Bindable -> Maybe Bindable
forall a. a -> Maybe a
Just (Bindable -> Maybe Bindable) -> Bindable -> Maybe Bindable
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 ->
            Bindable -> Maybe Bindable
forall a. a -> Maybe a
Just (Bindable -> Maybe Bindable) -> Bindable -> Maybe Bindable
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 -> Bindable -> Maybe Bindable
forall a. a -> Maybe a
Just (Bindable -> Maybe Bindable) -> Bindable -> Maybe Bindable
forall a b. (a -> b) -> a -> b
$ Int -> MouseOn -> Bindable
Drag Int
btn MouseOn
on
        UiMsg.MouseUp Int
btn -> Bindable -> Maybe Bindable
forall a. a -> Maybe a
Just (Bindable -> Maybe Bindable) -> Bindable -> Maybe Bindable
forall a b. (a -> b) -> a -> b
$ Int -> MouseOn -> Bindable
Release Int
btn MouseOn
on
        MouseState
_ -> Maybe Bindable
forall a. Maybe a
Nothing
    (Msg -> Maybe Message
Msg.midi -> Just (Midi.ChannelMessage Channel
chan (Midi.NoteOn Key
key Channel
_))) ->
        Bindable -> Maybe Bindable
forall a. a -> Maybe a
Just (Bindable -> Maybe Bindable) -> Bindable -> Maybe Bindable
forall a b. (a -> b) -> a -> b
$ Channel -> Key -> Bindable
Note Channel
chan Key
key
    Msg
_ -> Maybe Bindable
forall a. Maybe a
Nothing
    where
    on :: MouseOn
on = MouseOn -> (Context -> MouseOn) -> Maybe Context -> MouseOn
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) -> (Bool, Key) -> Maybe (Bool, Key)
forall a. a -> Maybe a
Just (Bool
False, Key
k)
        Just (KbdState
UiMsg.KeyRepeat, Key
k) -> (Bool, Key) -> Maybe (Bool, Key)
forall a. a -> Maybe a
Just (Bool
True, Key
k)
        Maybe (KbdState, Key)
_ -> Maybe (Bool, Key)
forall a. Maybe a
Nothing

mouse_on :: UiMsg.Context -> MouseOn
mouse_on :: Context -> MouseOn
mouse_on = MouseOn
-> ((Int, Track) -> MouseOn) -> Maybe (Int, Track) -> MouseOn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MouseOn
Elsewhere (Int, Track) -> MouseOn
forall {a}. (a, Track) -> MouseOn
on (Maybe (Int, Track) -> MouseOn)
-> (Context -> Maybe (Int, Track)) -> Context -> MouseOn
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 -> NamedCmd m -> Doc
forall a. Pretty a => a -> Doc
Pretty.format NamedCmd m
cmd
        Keymap Keymap m
keymap -> Keymap m -> Doc
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:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

instance Pretty KeySpec where
    pretty :: KeySpec -> Text
pretty (KeySpec Set Modifier
mods Bindable
bindable) =
        Text -> Text -> Text -> Text
forall a. (Monoid a, Eq a) => a -> a -> a -> a
Seq.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
" + " ([Text] -> Text)
-> (Set Modifier -> [Text]) -> Set Modifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Modifier -> Text) -> [Modifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Modifier -> Text
show_mod ([Modifier] -> [Text])
-> (Set Modifier -> [Modifier]) -> Set Modifier -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Modifier -> [Modifier]
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
button
    MidiMod Channel
chan Key
key -> Text
"midi " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
forall a. Show a => a -> Text
showt Key
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" chan " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Channel -> Text
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 -> Key -> Text
forall a. Pretty a => a -> Text
pretty Key
key
        Text -> Text -> Text
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 -> Int -> Text
forall {a}. (Eq a, Num a, Show a) => a -> Text
click_times Int
times Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"click "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
button Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MouseOn -> Text
forall a. Pretty a => a -> Text
pretty MouseOn
on
    Drag Int
button MouseOn
on -> Text
"drag " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
button Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MouseOn -> Text
forall a. Pretty a => a -> Text
pretty MouseOn
on
    Release Int
button MouseOn
on -> Text
"release " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
button Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MouseOn -> Text
forall a. Pretty a => a -> Text
pretty MouseOn
on
    Note Channel
chan Key
key -> Text
"midi " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
forall a. Show a => a -> Text
showt Key
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" channel " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Channel -> Text
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 = a -> Text
forall a. Show a => a -> Text
showt a
n Text -> Text -> Text
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
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
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 Status -> Integer
forall {a}. Num a => Status -> a
prio Status
s1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Status -> Integer
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
(PlayDirectArgs -> PlayDirectArgs -> Bool)
-> (PlayDirectArgs -> PlayDirectArgs -> Bool) -> Eq PlayDirectArgs
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
(Int -> PlayDirectArgs -> ShowS)
-> (PlayDirectArgs -> String)
-> ([PlayDirectArgs] -> ShowS)
-> Show PlayDirectArgs
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
(Int -> FloatingInput -> ShowS)
-> (FloatingInput -> String)
-> ([FloatingInput] -> ShowS)
-> Show FloatingInput
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) <-
        (LogT m ((Either Error (a, State, UiDamage), State), [Thru])
-> m (((Either Error (a, State, UiDamage), State), [Thru]), [Msg])
forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg])
Log.run (LogT m ((Either Error (a, State, UiDamage), State), [Thru])
 -> m (((Either Error (a, State, UiDamage), State), [Thru]), [Msg]))
-> (CmdT m a
    -> LogT m ((Either Error (a, State, UiDamage), State), [Thru]))
-> CmdT m a
-> m (((Either Error (a, State, UiDamage), State), [Thru]), [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerT Thru (LogT m) (Either Error (a, State, UiDamage), State)
-> LogT m ((Either Error (a, State, UiDamage), State), [Thru])
forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
Logger.run (LoggerT Thru (LogT m) (Either Error (a, State, UiDamage), State)
 -> LogT m ((Either Error (a, State, UiDamage), State), [Thru]))
-> (CmdT m a
    -> LoggerT
         Thru (LogT m) (Either Error (a, State, UiDamage), State))
-> CmdT m a
-> LogT m ((Either Error (a, State, UiDamage), State), [Thru])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
   State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage))
 -> State
 -> LoggerT
      Thru (LogT m) (Either Error (a, State, UiDamage), State))
-> State
-> StateT
     State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage))
-> LoggerT Thru (LogT m) (Either Error (a, State, UiDamage), State)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage))
-> State
-> LoggerT Thru (LogT m) (Either Error (a, State, UiDamage), State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
MonadState.runStateT State
cstate
            (StateT
   State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage))
 -> LoggerT
      Thru (LogT m) (Either Error (a, State, UiDamage), State))
-> (CmdT m a
    -> StateT
         State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage)))
-> CmdT m a
-> LoggerT Thru (LogT m) (Either Error (a, State, UiDamage), State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State
-> StateT (StateT State (LoggerT Thru (LogT m))) a
-> StateT
     State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage))
forall (m :: * -> *) a.
Monad m =>
State -> StateT m a -> m (Either Error (a, State, UiDamage))
Ui.run State
ustate (StateT (StateT State (LoggerT Thru (LogT m))) a
 -> StateT
      State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage)))
-> (CmdT m a -> StateT (StateT State (LoggerT Thru (LogT m))) a)
-> CmdT m a
-> StateT
     State (LoggerT Thru (LogT m)) (Either Error (a, State, UiDamage))
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.
    Result a -> m (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> m (Result a)) -> Result a -> m (Result a)
forall a b. (a -> b) -> a -> b
$ case Either Error (a, State, UiDamage)
ui_result of
        Left Error
Ui.Abort -> (State
cstate, [], [Msg]
logs, (a, State, UiDamage) -> Either Error (a, State, UiDamage)
forall a b. b -> Either a b
Right (a
abort_val, State
ustate, UiDamage
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) <-
        Maybe a -> RunCmd m m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run Maybe a
forall a. Maybe a
Nothing State
ui_state State
cmd_state ((a -> Maybe a) -> CmdT m a -> CmdT m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just CmdT m a
cmd)
    (Either String (a, State, State), [Msg])
-> m (Either String (a, State, State), [Msg])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either String (a, State, State), [Msg])
 -> m (Either String (a, State, State), [Msg]))
-> (Either String (a, State, State), [Msg])
-> m (Either String (a, State, State), [Msg])
forall a b. (a -> b) -> a -> b
$ (, [Msg]
logs) (Either String (a, State, State)
 -> (Either String (a, State, State), [Msg]))
-> Either String (a, State, State)
-> (Either String (a, State, State), [Msg])
forall a b. (a -> b) -> a -> b
$ case Either Error (Maybe a, State, UiDamage)
result of
        Left Error
err -> String -> Either String (a, State, State)
forall a b. a -> Either a b
Left (String -> Either String (a, State, State))
-> String -> Either String (a, State, State)
forall a b. (a -> b) -> a -> b
$ Error -> String
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 -> String -> Either String (a, State, State)
forall a b. a -> Either a b
Left String
"aborted"
            Just a
v -> (a, State, State) -> Either String (a, State, State)
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 = ((Either String (a, State, State), [Msg])
 -> (Either String a, [Msg]))
-> m (Either String (a, State, State), [Msg])
-> m (Either String a, [Msg])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either String (a, State, State) -> Either String a)
-> (Either String (a, State, State), [Msg])
-> (Either String a, [Msg])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((a, State, State) -> a)
-> Either String (a, State, State) -> Either String a
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a, State, State) -> a
forall {a} {b} {c}. (a, b, c) -> a
val_of)) (m (Either String (a, State, State), [Msg])
 -> m (Either String a, [Msg]))
-> (CmdT m a -> m (Either String (a, State, State), [Msg]))
-> CmdT m a
-> m (Either String a, [Msg])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State
-> State -> CmdT m a -> m (Either String (a, State, State), [Msg])
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 =
    Identity (Result (Maybe a)) -> Result (Maybe a)
forall a. Identity a -> a
Identity.runIdentity (Maybe a -> RunCmd Identity Identity (Maybe a)
forall (m :: * -> *) a. Monad m => a -> RunCmd m m a
run Maybe a
forall a. Maybe a
Nothing State
ui_state State
cmd_state ((a -> Maybe a) -> CmdT Identity a -> CmdT Identity (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
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 =
    Result Status -> IO (Result Status)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Status -> IO (Result Status))
-> Result Status -> IO (Result Status)
forall a b. (a -> b) -> a -> b
$ Identity (Result Status) -> Result Status
forall a. Identity a -> a
Identity.runIdentity (Status -> RunCmd Identity Identity Status
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 = Status -> RunCmd IO IO Status
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) <- State
-> State
-> CmdId a
-> (State, [Thru], [Msg], Either Error (Maybe a, State, UiDamage))
forall a. State -> State -> CmdT Identity a -> Result (Maybe a)
run_id (State
 -> State
 -> CmdId a
 -> (State, [Thru], [Msg], Either Error (Maybe a, State, UiDamage)))
-> m State
-> m (State
      -> CmdId a
      -> (State, [Thru], [Msg], Either Error (Maybe a, State, UiDamage)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m State
forall (m :: * -> *). M m => m State
Ui.get m (State
   -> CmdId a
   -> (State, [Thru], [Msg], Either Error (Maybe a, State, UiDamage)))
-> m State
-> m (CmdId a
      -> (State, [Thru], [Msg], Either Error (Maybe a, State, UiDamage)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m State
forall (m :: * -> *). M m => m State
get m (CmdId a
   -> (State, [Thru], [Msg], Either Error (Maybe a, State, UiDamage)))
-> m (CmdId a)
-> m (State, [Thru], [Msg],
      Either Error (Maybe a, State, UiDamage))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CmdId a -> m (CmdId a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmdId a
cmd
    (Msg -> m ()) -> [Msg] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Msg -> m ()
forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    case Either Error (Maybe a, State, UiDamage)
result of
        Left Error
err -> Error -> m a
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 -> m a
forall (m :: * -> *) a. M m => m a
abort
            Just a
val -> do
                State -> m ()
forall (m :: * -> *). M m => State -> m ()
put State
cmd_state
                (Thru -> m ()) -> [Thru] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Thru -> m ()
forall (m :: * -> *). M m => Thru -> m ()
write_thru [Thru]
thru
                UiDamage -> m ()
forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage UiDamage
damage
                State -> m ()
forall (m :: * -> *). M m => State -> m ()
Ui.unsafe_put State
ui_state
                a -> m a
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
_ = Status -> m Status
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 <- m Status -> m (Maybe 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 -> [a -> m Status] -> a -> m Status
forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
sequence_cmds [a -> m Status]
cmds a
msg
        Just Status
Continue -> [a -> m Status] -> a -> m Status
forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status
sequence_cmds [a -> m Status]
cmds a
msg
        Just Status
status -> Status -> m 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 -> b) -> CmdT m a -> CmdT m b)
-> (forall a b. a -> CmdT m b -> CmdT m a) -> Functor (CmdT m)
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, Applicative (CmdT m)
Applicative (CmdT m)
-> (forall a b. CmdT m a -> (a -> CmdT m b) -> CmdT m b)
-> (forall a b. CmdT m a -> CmdT m b -> CmdT m b)
-> (forall a. a -> CmdT m a)
-> Monad (CmdT m)
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, Monad (CmdT m)
Monad (CmdT m) -> (forall a. IO a -> CmdT m a) -> MonadIO (CmdT m)
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, Functor (CmdT m)
Functor (CmdT m)
-> (forall a. a -> CmdT m a)
-> (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 a b. CmdT m a -> CmdT m b -> CmdT m b)
-> (forall a b. CmdT m a -> CmdT m b -> CmdT m a)
-> Applicative (CmdT m)
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 (Applicative m, Monad m) => M (CmdT m) where
    get :: CmdT m State
get = (CmdStack m State -> CmdT m State
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (CmdStack m State -> CmdT m State)
-> (StateT State (LoggerT Thru (LogT m)) State -> CmdStack m State)
-> StateT State (LoggerT Thru (LogT m)) State
-> CmdT m State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State (LoggerT Thru (LogT m)) State -> CmdStack m State
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) StateT State (LoggerT Thru (LogT m)) State
forall s (m :: * -> *). MonadState s m => m s
MonadState.get
    put :: State -> CmdT m ()
put State
st = (CmdStack m () -> CmdT m ()
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (CmdStack m () -> CmdT m ())
-> (StateT State (LoggerT Thru (LogT m)) () -> CmdStack m ())
-> StateT State (LoggerT Thru (LogT m)) ()
-> CmdT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State (LoggerT Thru (LogT m)) () -> CmdStack m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (State -> StateT State (LoggerT Thru (LogT m)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
MonadState.put State
st)
    write_thru :: Thru -> CmdT m ()
write_thru Thru
msg = (CmdStack m () -> CmdT m ()
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (CmdStack m () -> CmdT m ())
-> (LoggerT Thru (LogT m) () -> CmdStack m ())
-> LoggerT Thru (LogT m) ()
-> CmdT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State (LoggerT Thru (LogT m)) () -> CmdStack m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT State (LoggerT Thru (LogT m)) () -> CmdStack m ())
-> (LoggerT Thru (LogT m) ()
    -> StateT State (LoggerT Thru (LogT m)) ())
-> LoggerT Thru (LogT m) ()
-> CmdStack m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerT Thru (LogT m) () -> StateT State (LoggerT Thru (LogT m)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (Thru -> LoggerT Thru (LogT m) ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
Logger.log Thru
msg)
    abort :: forall a. CmdT m a
abort = Error -> CmdT m a
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 = CmdT m (Maybe a) -> (Error -> CmdT m (Maybe a)) -> CmdT m (Maybe a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError ((a -> Maybe a) -> CmdT m a -> CmdT m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just CmdT m a
m) Error -> CmdT m (Maybe a)
forall {m :: * -> *} {a}.
MonadError Error m =>
Error -> m (Maybe a)
catch
        where
        catch :: Error -> m (Maybe a)
catch Error
Ui.Abort = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        catch Error
err = Error -> m (Maybe a)
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
(Int -> Thru -> ShowS)
-> (Thru -> String) -> ([Thru] -> ShowS) -> Show Thru
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 (Message -> Thru) -> Message -> Thru
forall a b. (a -> b) -> a -> b
$ WriteMessage -> Message
Midi.Interface.Midi (WriteMessage -> Message) -> WriteMessage -> Message
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 = Thru -> m ()
forall (m :: * -> *). M m => Thru -> m ()
write_thru (Thru -> m ()) -> Thru -> m ()
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 = Thru -> m ()
forall (m :: * -> *). M m => Thru -> m ()
write_thru (Thru -> m ()) -> ([OSC] -> Thru) -> [OSC] -> m ()
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 = CmdStack m a -> CmdT m a
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (CmdStack m a -> CmdT m a)
-> (m a -> CmdStack m a) -> m a -> CmdT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State (LoggerT Thru (LogT m)) a -> CmdStack m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT State (LoggerT Thru (LogT m)) a -> CmdStack m a)
-> (m a -> StateT State (LoggerT Thru (LogT m)) a)
-> m a
-> CmdStack m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerT Thru (LogT m) a -> StateT State (LoggerT Thru (LogT m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LoggerT Thru (LogT m) a -> StateT State (LoggerT Thru (LogT m)) a)
-> (m a -> LoggerT Thru (LogT m) a)
-> m a
-> StateT State (LoggerT Thru (LogT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> LoggerT Thru (LogT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LogT m a -> LoggerT Thru (LogT m) a)
-> (m a -> LogT m a) -> m a -> LoggerT Thru (LogT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> LogT m a
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 = CmdStack m () -> CmdT m ()
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (CmdStack m () -> CmdT m ())
-> (Msg -> CmdStack m ()) -> Msg -> CmdT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT State (LoggerT Thru (LogT m)) () -> CmdStack m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT State (LoggerT Thru (LogT m)) () -> CmdStack m ())
-> (Msg -> StateT State (LoggerT Thru (LogT m)) ())
-> Msg
-> CmdStack m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerT Thru (LogT m) () -> StateT State (LoggerT Thru (LogT m)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LoggerT Thru (LogT m) ()
 -> StateT State (LoggerT Thru (LogT m)) ())
-> (Msg -> LoggerT Thru (LogT m) ())
-> Msg
-> StateT State (LoggerT Thru (LogT m)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m () -> LoggerT Thru (LogT m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LogT m () -> LoggerT Thru (LogT m) ())
-> (Msg -> LogT m ()) -> Msg -> LoggerT Thru (LogT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> LogT m ()
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 = CmdStack m State -> CmdT m State
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT CmdStack m State
forall (m :: * -> *). M m => m State
Ui.get
    unsafe_put :: State -> CmdT m ()
unsafe_put State
st = CmdStack m () -> CmdT m ()
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (State -> CmdStack m ()
forall (m :: * -> *). M m => State -> m ()
Ui.unsafe_put State
st)
    damage :: UiDamage -> CmdT m ()
damage UiDamage
upd = CmdStack m () -> CmdT m ()
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (UiDamage -> CmdStack m ()
forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage UiDamage
upd)
    get_damage :: CmdT m UiDamage
get_damage = CmdStack m UiDamage -> CmdT m UiDamage
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT CmdStack m UiDamage
forall (m :: * -> *). M m => m UiDamage
Ui.get_damage
    throw_error :: forall a. Error -> CmdT m a
throw_error Error
msg = CmdStack m a -> CmdT m a
forall (m :: * -> *) a. CmdStack m a -> CmdT m a
CmdT (Error -> CmdStack m a
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 = Text -> m a
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 = m (Maybe a) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe a) -> m ()) -> m (Maybe a) -> m ()
forall a b. (a -> b) -> a -> b
$ m a -> m (Maybe a)
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 =
    (Text -> CmdT IO a)
-> (a -> CmdT IO a) -> Either Text a -> CmdT IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> CmdT IO a
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw a -> CmdT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> CmdT IO a)
-> (IO a -> CmdT IO (Either Text a)) -> IO a -> CmdT IO a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either Text a) -> CmdT IO (Either Text a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text a) -> CmdT IO (Either Text a))
-> (IO a -> IO (Either Text a)) -> IO a -> CmdT IO (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> IO (Either Text a))
-> IO (Either Text a) -> IO (Either Text a)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle SomeException -> IO (Either Text a)
forall a. SomeException -> IO (Either Text a)
handle (IO (Either Text a) -> IO (Either Text a))
-> (IO a -> IO (Either Text a)) -> IO a -> IO (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Either Text a
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 = Either Text a -> IO (Either Text a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text a -> IO (Either Text a))
-> (SomeException -> Either Text a)
-> SomeException
-> IO (Either Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a)
-> (SomeException -> Text) -> SomeException -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"io exception: "<>) (Text -> Text) -> (SomeException -> Text) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
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 = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. M m => m a
abort a -> m a
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 = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m a
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw Text
msg) a -> m a
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 = (err -> m a) -> (a -> m a) -> Either err a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> m a
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
throw (Text -> m a) -> (err -> Text) -> err -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
fmt_err) a -> m a
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
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
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
(Int -> SaveFile -> ShowS)
-> (SaveFile -> String) -> ([SaveFile] -> ShowS) -> Show SaveFile
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
(SaveFile -> SaveFile -> Bool)
-> (SaveFile -> SaveFile -> Bool) -> Eq SaveFile
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
(Int -> Writable -> ShowS)
-> (Writable -> String) -> ([Writable] -> ShowS) -> Show Writable
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
(Writable -> Writable -> Bool)
-> (Writable -> Writable -> Bool) -> Eq Writable
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
(Saved -> Saved -> Bool) -> (Saved -> Saved -> Bool) -> Eq Saved
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
(Int -> Saved -> ShowS)
-> (Saved -> String) -> ([Saved] -> ShowS) -> Show Saved
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
(SavedState -> SavedState -> Bool)
-> (SavedState -> SavedState -> Bool) -> Eq SavedState
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
(Int -> SavedState -> ShowS)
-> (SavedState -> String)
-> ([SavedState] -> ShowS)
-> Show SavedState
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
(Int -> KeycapsUpdate -> ShowS)
-> (KeycapsUpdate -> String)
-> ([KeycapsUpdate] -> ShowS)
-> Show KeycapsUpdate
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
(Int -> KeycapsState -> ShowS)
-> (KeycapsState -> String)
-> ([KeycapsState] -> ShowS)
-> Show KeycapsState
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
(KeycapsState -> KeycapsState -> Bool)
-> (KeycapsState -> KeycapsState -> Bool) -> Eq KeycapsState
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 -> Maybe String
forall a. Maybe a
Nothing
    Just (Writable
_, SaveState Canonical
fn) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeDirectory ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Canonical -> String
Path.to_path Canonical
fn
    Just (Writable
_, SaveRepo Canonical
repo) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
FilePath.takeDirectory ShowS -> ShowS
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
(Int -> KyCache -> ShowS)
-> (KyCache -> String) -> ([KyCache] -> ShowS) -> Show KyCache
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
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
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
(Int -> Fingerprint -> ShowS)
-> (Fingerprint -> String)
-> ([Fingerprint] -> ShowS)
-> Show Fingerprint
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]
fnames1[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<>[String]
fnames2) (Int -> Int -> Int
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 = Fingerprint -> Fingerprint -> Fingerprint
forall a. Semigroup a => a -> a -> a
(<>)
instance Pretty Fingerprint where
    pretty :: Fingerprint -> Text
pretty (Fingerprint [String]
files Int
word) = [String] -> Text
forall a. Pretty a => a -> Text
pretty [String]
files Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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 ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
fnames)
        ((Int -> Text -> Int) -> Int -> [Text] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
Hashable.hashWithSalt Int
0 [Text]
contents)
    where
    ([String]
fnames, [Text]
contents) = [(String, Text)] -> ([String], [Text])
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 = Maybe (Writable, SaveFile)
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 = Maybe KyCache
forall a. Maybe a
Nothing
    , state_derive_immediately :: Set BlockId
state_derive_immediately = Set BlockId
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 = Map Modifier Modifier
forall k a. Map k a
Map.empty
    , state_focused_view :: Maybe ViewId
state_focused_view = Maybe ViewId
forall a. Maybe a
Nothing
    , state_screens :: [Rect]
state_screens = []
    , state_keycaps :: Maybe KeycapsState
state_keycaps = Maybe KeycapsState
forall a. Maybe a
Nothing
    , state_keycaps_update :: Maybe KeycapsUpdate
state_keycaps_update = Maybe KeycapsUpdate
forall a. Maybe a
Nothing
    , state_global_status :: Map Text Text
state_global_status = Map Text Text
forall k a. Map k a
Map.empty
    , state_play :: PlayState
state_play = PlayState
initial_play_state
    , state_hooks :: Hooks
state_hooks = 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 = Maybe ViewId
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
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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 (WriteMessage -> Message) -> WriteMessage -> Message
forall a b. (a -> b) -> a -> b
$ WriteMessage -> WriteMessage
map_wdev WriteMessage
wmsg
            Message
_ -> Message
imsg
    Maybe Text
mb_err <- Interface -> Message -> IO (Maybe Text)
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
    Maybe Text -> (Text -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Text
mb_err ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
err ->
        Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"error writing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Message -> Text
forall a. Pretty a => a -> Text
pretty Message
out Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> 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 = WriteDevice
-> WriteDevice -> Map WriteDevice WriteDevice -> WriteDevice
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))))
    } deriving (Int -> PlayState -> ShowS
[PlayState] -> ShowS
PlayState -> String
(Int -> PlayState -> ShowS)
-> (PlayState -> String)
-> ([PlayState] -> ShowS)
-> Show PlayState
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)

-- | 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.
newtype Thread = Thread (Async.Async ())

instance Show Thread where
    show :: Thread -> String
show = ThreadId -> String
forall a. Show a => a -> String
show (ThreadId -> String) -> (Thread -> ThreadId) -> Thread -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async () -> ThreadId
forall a. Async a -> ThreadId
Async.asyncThreadId (Async () -> ThreadId)
-> (Thread -> Async ()) -> Thread -> ThreadId
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) = Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
async

kill_performance_threads :: State -> IO ()
kill_performance_threads :: State -> IO ()
kill_performance_threads =
    (Thread -> IO ()) -> [Thread] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Thread -> IO ()
kill_thread ([Thread] -> IO ()) -> (State -> [Thread]) -> State -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map BlockId Thread -> [Thread]
forall k a. Map k a -> [a]
Map.elems (Map BlockId Thread -> [Thread])
-> (State -> Map BlockId Thread) -> State -> [Thread]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Map BlockId Thread
state_performance_threads (PlayState -> Map BlockId Thread)
-> (State -> PlayState) -> State -> Map BlockId Thread
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 <- (State -> [(BlockId, Thread)]) -> CmdT IO [(BlockId, Thread)]
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets ((State -> [(BlockId, Thread)]) -> CmdT IO [(BlockId, Thread)])
-> (State -> [(BlockId, Thread)]) -> CmdT IO [(BlockId, Thread)]
forall a b. (a -> b) -> a -> b
$ Map BlockId Thread -> [(BlockId, Thread)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map BlockId Thread -> [(BlockId, Thread)])
-> (State -> Map BlockId Thread) -> State -> [(BlockId, Thread)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Map BlockId Thread
state_performance_threads (PlayState -> Map BlockId Thread)
-> (State -> PlayState) -> State -> Map BlockId Thread
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
state_play
    [(BlockId, Thread)]
alive <- IO [(BlockId, Thread)] -> CmdT IO [(BlockId, Thread)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(BlockId, Thread)] -> CmdT IO [(BlockId, Thread)])
-> IO [(BlockId, Thread)] -> CmdT IO [(BlockId, Thread)]
forall a b. (a -> b) -> a -> b
$ ((BlockId, Thread) -> IO Bool)
-> [(BlockId, Thread)] -> IO [(BlockId, Thread)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Thread -> IO Bool
is_alive (Thread -> IO Bool)
-> ((BlockId, Thread) -> Thread) -> (BlockId, Thread) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockId, Thread) -> Thread
forall a b. (a, b) -> b
snd) [(BlockId, Thread)]
threads
    [BlockId] -> CmdT IO [BlockId]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockId] -> CmdT IO [BlockId]) -> [BlockId] -> CmdT IO [BlockId]
forall a b. (a -> b) -> a -> b
$ ((BlockId, Thread) -> BlockId) -> [(BlockId, Thread)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, Thread) -> BlockId
forall a b. (a, b) -> a
fst [(BlockId, Thread)]
alive
    where
    is_alive :: Thread -> IO Bool
is_alive (Thread Async ()
async) = Maybe (Either SomeException ()) -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing (Maybe (Either SomeException ()) -> Bool)
-> IO (Maybe (Either SomeException ())) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async () -> IO (Maybe (Either SomeException ()))
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 = Map BlockId Performance
forall k a. Map k a
Map.empty
    , state_current_performance :: Map BlockId Performance
state_current_performance = Map BlockId Performance
forall k a. Map k a
Map.empty
    , state_performance_threads :: Map BlockId Thread
state_performance_threads = Map BlockId Thread
forall k a. Map k a
Map.empty
    , state_play_step :: TimeStep
state_play_step = Step -> TimeStep
TimeStep.time_step (Step -> TimeStep) -> Step -> TimeStep
forall a b. (a -> b) -> a -> b
$
        MarklistMatch -> Rank -> Step
TimeStep.RelativeMark MarklistMatch
TimeStep.AllMarklists Rank
Meter.Section
    , state_step :: Maybe StepState
state_step = Maybe StepState
forall a. Maybe a
Nothing
    , state_play_multiplier :: RealTime
state_play_multiplier = Double -> RealTime
RealTime.seconds Double
1
    , state_sync :: Maybe SyncConfig
state_sync = Maybe SyncConfig
forall a. Maybe a
Nothing
    , state_im_progress :: Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
state_im_progress = Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime)))
forall a. Monoid a => a
mempty
    }

-- | 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
(Int -> StepState -> ShowS)
-> (StepState -> String)
-> ([StepState] -> ShowS)
-> Show StepState
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
(Int -> SyncConfig -> ShowS)
-> (SyncConfig -> String)
-> ([SyncConfig] -> ShowS)
-> Show SyncConfig
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", WriteDevice -> Doc
forall a. Pretty a => a -> Doc
Pretty.format WriteDevice
dev)
        , (Text
"device_id", Channel -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Channel
dev_id)
        , (Text
"mtc", Bool -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Bool
mtc)
        , (Text
"frame_rate", Text -> Doc
Pretty.text (FrameRate -> 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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([[(ViewId, Maybe TrackSelection)] -> CmdId ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
sel) String -> ShowS
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 [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
-> [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
-> [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
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 = Hooks -> Hooks -> Hooks
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
(EditState -> EditState -> Bool)
-> (EditState -> EditState -> Bool) -> Eq EditState
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
(Int -> EditState -> ShowS)
-> (EditState -> String)
-> ([EditState] -> ShowS)
-> Show EditState
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 = RecordedActions
forall a. Monoid a => a
mempty
    , state_instrument_attributes :: Map Instrument Attributes
state_instrument_attributes = Map Instrument Attributes
forall a. Monoid a => a
mempty
    , state_edit_box :: (Box, Box)
state_edit_box = (Box
box, Box
box)
    } where box :: Box
box = (Color -> Char -> Box) -> (Color, Char) -> 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
(EditMode -> EditMode -> Bool)
-> (EditMode -> EditMode -> Bool) -> Eq EditMode
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
(Int -> EditMode -> ShowS)
-> (EditMode -> String) -> ([EditMode] -> ShowS) -> Show EditMode
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 = EditMode -> Text
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
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
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
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
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 ->
            Text -> Text
forall a. Pretty a => a -> Text
pretty Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe ScoreTime -> Text
forall a. Pretty a => a -> Text
pretty Maybe ScoreTime
maybe_dur Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        ReplaceText Text
text -> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
text
        PrependText Text
text -> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"+"
        AppendText Text
text -> Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
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
(WriteDeviceState -> WriteDeviceState -> Bool)
-> (WriteDeviceState -> WriteDeviceState -> Bool)
-> Eq WriteDeviceState
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
(Int -> WriteDeviceState -> ShowS)
-> (WriteDeviceState -> String)
-> ([WriteDeviceState] -> ShowS)
-> Show WriteDeviceState
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 = Map NoteId Addr
forall k a. Map k a
Map.empty
    , wdev_note_key :: Map NoteId Key
wdev_note_key = Map NoteId Key
forall k a. Map k a
Map.empty
    , wdev_addr_serial :: Map Addr Int
wdev_addr_serial = Map Addr Int
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 = Maybe NoteId
forall a. Maybe a
Nothing
    , wdev_pitch_track :: Map NoteId (BlockId, Int)
wdev_pitch_track = Map NoteId (BlockId, Int)
forall k a. Map k a
Map.empty
    , wdev_addr_inst :: Map Addr Patch
wdev_addr_inst = Map Addr Patch
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 ([TrackWarp] -> TempoFunction)
-> (Performance -> [TrackWarp]) -> Performance -> TempoFunction
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 ([TrackWarp] -> InverseTempoFunction)
-> (Performance -> [TrackWarp])
-> Performance
-> InverseTempoFunction
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 ([TrackWarp] -> ClosestWarpFunction)
-> (Performance -> [TrackWarp])
-> Performance
-> ClosestWarpFunction
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", InstrumentCalls -> Doc
forall a. Pretty a => a -> Doc
Pretty.format InstrumentCalls
calls)
        , (Text
"cmds", [HandlerId] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [HandlerId]
cmds)
        , (Text
"thru", Maybe ThruFunction -> Doc
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 (InstrumentCode -> InstrumentCalls)
-> InstrumentCode -> InstrumentCalls
forall a b. (a -> b) -> a -> b
$ Common InstrumentCode -> InstrumentCode
forall code. Common code -> code
Common.common_code (Common InstrumentCode -> InstrumentCode)
-> Common InstrumentCode -> InstrumentCode
forall a b. (a -> b) -> a -> b
$ Inst InstrumentCode -> Common InstrumentCode
forall code. Inst code -> Common code
Inst.inst_common (Inst InstrumentCode -> Common InstrumentCode)
-> Inst InstrumentCode -> Common InstrumentCode
forall a b. (a -> b) -> a -> b
$
        ResolvedInstrument -> Inst InstrumentCode
inst_instrument ResolvedInstrument
resolved
    , inst_environ :: Environ
inst_environ = Environ -> Environ
REnv.convert (Environ -> Environ) -> Environ -> Environ
forall a b. (a -> b) -> a -> b
$
        Config -> Environ
Common.config_environ (Config -> Environ) -> 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 = Inst InstrumentCode -> [Attributes]
forall code. Inst code -> [Attributes]
Inst.inst_attributes (ResolvedInstrument -> Inst InstrumentCode
inst_instrument ResolvedInstrument
resolved)
    , inst_elements :: Set Text
inst_elements = case Inst InstrumentCode -> Backend
forall code. Inst code -> Backend
Inst.inst_backend (ResolvedInstrument -> Inst InstrumentCode
inst_instrument ResolvedInstrument
resolved) of
        Inst.Im Patch
patch -> Patch -> Set Text
Im.Patch.patch_elements Patch
patch
        Backend
_ -> Set Text
forall a. Monoid a => a
mempty
    }

empty_code :: InstrumentCode
empty_code :: InstrumentCode
empty_code = InstrumentCode
    { inst_calls :: InstrumentCalls
inst_calls = InstrumentCalls
forall a. Monoid a => a
mempty
    , inst_postproc :: InstrumentPostproc
inst_postproc = (,[])
    , inst_cmds :: [HandlerId]
inst_cmds = []
    , inst_thru :: Maybe ThruFunction
inst_thru = Maybe ThruFunction
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
(Int -> History -> ShowS)
-> (History -> String) -> ([History] -> ShowS) -> Show History
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 [] Maybe LastCmd
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
(Int -> LastCmd -> ShowS)
-> (LastCmd -> String) -> ([LastCmd] -> ShowS) -> Show LastCmd
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
(Int -> HistoryConfig -> ShowS)
-> (HistoryConfig -> String)
-> ([HistoryConfig] -> ShowS)
-> Show HistoryConfig
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 Maybe Commit
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
(Int -> HistoryCollect -> ShowS)
-> (HistoryCollect -> String)
-> ([HistoryCollect] -> ShowS)
-> Show HistoryCollect
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 = Maybe EditMode
forall a. Maybe a
Nothing
    , state_suppressed :: Maybe SaveHistory
state_suppressed = Maybe SaveHistory
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
(Int -> HistoryEntry -> ShowS)
-> (HistoryEntry -> String)
-> ([HistoryEntry] -> ShowS)
-> Show HistoryEntry
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 = UiDamage
forall a. Monoid a => a
mempty
    , hist_names :: [Text]
hist_names = []
    , hist_commit :: Maybe Commit
hist_commit = Maybe 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", [HistoryEntry] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [HistoryEntry]
past)
        , (Text
"present", HistoryEntry -> Doc
forall a. Pretty a => a -> Doc
Pretty.format HistoryEntry
present)
        , (Text
"future", [HistoryEntry] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [HistoryEntry]
future)
        , (Text
"last_cmd", Text -> Doc
Pretty.text (Maybe LastCmd -> 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) =
        Maybe Commit -> Doc
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.<+> UiDamage -> Doc
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", Int -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Int
keep)
        , (Text
"last_commit", Maybe Commit -> Doc
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", [Text] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Text]
names)
            , (Text
"suppress_edit", Maybe EditMode -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe EditMode
edit)
            , (Text
"suppressed", Maybe SaveHistory -> Doc
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
(SelectionHistory -> SelectionHistory -> Bool)
-> (SelectionHistory -> SelectionHistory -> Bool)
-> Eq SelectionHistory
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
(Int -> SelectionHistory -> ShowS)
-> (SelectionHistory -> String)
-> ([SelectionHistory] -> ShowS)
-> Show SelectionHistory
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", [(ViewId, Selection)] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [(ViewId, Selection)]
past)
        , (Text
"future", [(ViewId, Selection)] -> Doc
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
(Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool) -> Eq Modifier
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
Eq Modifier
-> (Modifier -> Modifier -> Ordering)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Modifier)
-> (Modifier -> Modifier -> Modifier)
-> Ord 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
(Int -> Modifier -> ShowS)
-> (Modifier -> String) -> ([Modifier] -> ShowS) -> Show Modifier
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]
(Int -> ReadS Modifier)
-> ReadS [Modifier]
-> ReadPrec Modifier
-> ReadPrec [Modifier]
-> Read 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 -> Modifier -> Text
forall a. Pretty a => a -> Text
pretty Modifier
mod
        MouseMod Int
button Maybe (Int, Track)
mb_track -> Text
"MouseMod" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int, Maybe (Int, Track)) -> Text
forall a. Pretty a => a -> Text
pretty (Int
button, Maybe (Int, Track)
mb_track)
        MidiMod Channel
chan Key
key -> Text
"MidiMod" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Channel, Key) -> Text
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)
_) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
btn
mouse_mod_btn Modifier
_ = Maybe Int
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 Maybe (Int, Track)
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 <- m State
forall (m :: * -> *). M m => m State
get
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
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 <- m State
forall (m :: * -> *). M m => m State
get
    State -> m ()
forall (m :: * -> *). M m => State -> m ()
put (State -> m ()) -> State -> m ()
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 = (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
modify ((State -> State) -> m ()) -> (State -> State) -> m ()
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 <- (State -> [Rect]) -> m [Rect]
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.
    Rect -> m Rect
forall (m :: * -> *) a. Monad m => a -> m a
return (Rect -> m Rect) -> Rect -> m Rect
forall a b. (a -> b) -> a -> b
$ Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Int -> Int -> Rect
Rect.xywh Int
0 Int
0 Int
800 Int
600) (Maybe Rect -> Rect) -> Maybe Rect -> Rect
forall a b. (a -> b) -> a -> b
$ case Maybe (Int, Int)
mb_point of
        Maybe (Int, Int)
Nothing -> [Rect] -> Maybe Rect
forall a. [a] -> Maybe a
Seq.head [Rect]
screens
        Just (Int, Int)
point -> (Rect -> Double) -> [Rect] -> Maybe Rect
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.minimum_on ((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 =
    (State -> Maybe Performance) -> m (Maybe Performance)
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets ((State -> Maybe Performance) -> m (Maybe Performance))
-> (State -> Maybe Performance) -> m (Maybe Performance)
forall a b. (a -> b) -> a -> b
$ BlockId -> Map BlockId Performance -> Maybe Performance
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BlockId
block_id (Map BlockId Performance -> Maybe Performance)
-> (State -> Map BlockId Performance) -> State -> Maybe Performance
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlayState -> Map BlockId Performance
state_performance (PlayState -> Map BlockId Performance)
-> (State -> PlayState) -> State -> Map BlockId 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 = Maybe Performance -> m Performance
forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless (Maybe Performance -> m Performance)
-> m (Maybe Performance) -> m Performance
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BlockId -> m (Maybe Performance)
forall (m :: * -> *). M m => BlockId -> m (Maybe Performance)
lookup_performance BlockId
block_id

-- | Clear all performances, which will cause them to be rederived.
-- It's in IO because it wants to kill any threads still deriving.
--
-- TODO I'm not actually sure if this is safe.  A stale DeriveComplete
-- coming in should be ignored, right?  Why not Ui.update_all?
invalidate_performances :: CmdT IO ()
invalidate_performances :: CmdT IO ()
invalidate_performances = do
    IO () -> CmdT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CmdT IO ()) -> (State -> IO ()) -> State -> CmdT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> IO ()
kill_performance_threads (State -> CmdT IO ()) -> CmdT IO State -> CmdT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmdT IO State
forall (m :: * -> *). M m => m State
get
    (PlayState -> PlayState) -> CmdT IO ()
forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
modify_play_state ((PlayState -> PlayState) -> CmdT IO ())
-> (PlayState -> PlayState) -> CmdT IO ()
forall a b. (a -> b) -> a -> b
$ \PlayState
state -> PlayState
state
        { state_performance :: Map BlockId Performance
state_performance = Map BlockId Performance
forall a. Monoid a => a
mempty
        , state_performance_threads :: Map BlockId Thread
state_performance_threads = Map BlockId Thread
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 <- (State -> String) -> CmdT IO String
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> String
score_path
    IO (Maybe ()) -> CmdT IO (Maybe ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> CmdT IO (Maybe ()))
-> IO (Maybe ()) -> CmdT IO (Maybe ())
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
        IO () -> IO (Maybe ())
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.removeDirectoryRecursive (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> String -> BlockId -> String
Shared.Config.notesDirectory String
imDir String
path BlockId
block_id
        IO () -> IO (Maybe ())
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
Directory.removeDirectoryRecursive (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> String -> BlockId -> String
Shared.Config.outputDirectory String
imDir String
path BlockId
block_id
    () -> CmdT IO ()
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 = (State -> Map Modifier Modifier) -> m (Map Modifier Modifier)
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 = Maybe ViewId -> m ViewId
forall (m :: * -> *) a. M m => Maybe a -> m a
abort_unless (Maybe ViewId -> m ViewId) -> m (Maybe ViewId) -> m ViewId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (State -> Maybe ViewId) -> m (Maybe ViewId)
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 (View -> BlockId) -> m View -> m BlockId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view (ViewId -> m View) -> m ViewId -> m View
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ViewId
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 = (State -> Maybe ViewId) -> m (Maybe ViewId)
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 <- m (Maybe ViewId)
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 -> (View -> Maybe BlockId) -> m View -> m (Maybe BlockId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just (BlockId -> Maybe BlockId)
-> (View -> BlockId) -> View -> Maybe BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. View -> BlockId
Block.view_block) (ViewId -> m View
forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id)
        Maybe ViewId
Nothing -> Maybe BlockId -> m (Maybe BlockId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockId
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 <- ViewId -> m (Maybe View)
forall (m :: * -> *). M m => ViewId -> m (Maybe View)
Ui.lookup_view ViewId
view_id
    case Maybe View
view of
        Maybe View
Nothing ->
            Text -> m ()
forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Ui.throw (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Cmd.focus on non-existent view: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ViewId -> Text
forall a. Show a => a -> Text
showt ViewId
view_id
        Maybe View
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    UiDamage -> m ()
forall (m :: * -> *). M m => UiDamage -> m ()
Ui.damage (UiDamage -> m ()) -> UiDamage -> m ()
forall a b. (a -> b) -> a -> b
$ UiDamage
forall a. Monoid a => a
mempty { _bring_to_front :: Set ViewId
Update._bring_to_front = ViewId -> Set ViewId
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 = (State -> TimeStep) -> m TimeStep
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (EditState -> TimeStep
state_time_step (EditState -> TimeStep)
-> (State -> EditState) -> State -> TimeStep
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 <- m ViewId
forall (m :: * -> *). M m => m ViewId
get_focused_view
    Maybe Selection
sel <- ViewId -> Int -> m (Maybe Selection)
forall (m :: * -> *). M m => ViewId -> Int -> m (Maybe Selection)
Ui.get_selection ViewId
view_id Int
Config.insert_selnum
    Maybe Int -> m (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Selection -> Int) -> Maybe Selection -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Selection -> Int
Sel.start_track 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 = ViewId -> (Int, Text) -> Maybe Text -> m ()
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 <- (State -> Map Text Text) -> m (Map Text Text)
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Map Text Text
state_global_status
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key Map Text Text
status_map Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
val) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
            State
st { state_global_status :: Map Text Text
state_global_status = Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key Text
val Map Text Text
status_map }
        Text -> m ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"global status: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -- " Text -> Text -> 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 <- (State -> [ViewId]) -> m [ViewId]
forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets (Map ViewId View -> [ViewId]
forall k a. Map k a -> [k]
Map.keys (Map ViewId View -> [ViewId])
-> (State -> Map ViewId View) -> State -> [ViewId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views)
    [ViewId] -> (ViewId -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ViewId]
view_ids ((ViewId -> m ()) -> m ()) -> (ViewId -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ViewId
view_id -> ViewId -> (Int, Text) -> Maybe Text -> m ()
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 InstrumentCode
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
(Int -> ResolvedInstrument -> ShowS)
-> (ResolvedInstrument -> String)
-> ([ResolvedInstrument] -> ShowS)
-> Show ResolvedInstrument
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 (Qualified -> Text)
-> (ResolvedInstrument -> Qualified) -> ResolvedInstrument -> Text
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 = Inst InstrumentCode -> Common InstrumentCode
forall code. Inst code -> Common code
Inst.inst_common (Inst InstrumentCode -> Common InstrumentCode)
-> (ResolvedInstrument -> Inst InstrumentCode)
-> ResolvedInstrument
-> Common InstrumentCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Inst InstrumentCode
inst_instrument

instance Pretty ResolvedInstrument where
    format :: ResolvedInstrument -> Doc
format (ResolvedInstrument Inst InstrumentCode
instrument Qualified
qualified Config
common_config Backend
backend) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"ResolvedInstrument"
            [ (Text
"instrument", Inst InstrumentCode -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Inst InstrumentCode
instrument)
            , (Text
"qualified", Qualified -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Qualified
qualified)
            , (Text
"common_config", Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
common_config)
            , (Text
"backend", Backend -> Doc
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
(Int -> Backend -> ShowS)
-> (Backend -> String) -> ([Backend] -> ShowS) -> Show Backend
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) = (Patch, Config) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format (Patch
patch, Config
config)
    format (Im Patch
patch) = Patch -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Patch
patch
    format (Sc Patch
patch) = Patch -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Patch
patch
    format (Dummy Text
msg) = Doc
"Dummy \"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Pretty.text Text
msg Doc -> Doc -> Doc
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 -> (Patch, Config) -> Maybe (Patch, Config)
forall a. a -> Maybe a
Just (Patch
patch, Config
config)
    Backend
_ -> Maybe (Patch, Config)
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 -> Patch -> Maybe Patch
forall a. a -> Maybe a
Just Patch
patch
    Backend
_ -> Maybe Patch
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 =
    Text -> Maybe (Patch, Config) -> m (Patch, Config)
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"not a midi instrument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst) (Maybe (Patch, Config) -> m (Patch, Config))
-> (ResolvedInstrument -> Maybe (Patch, Config))
-> ResolvedInstrument
-> m (Patch, Config)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Maybe (Patch, Config)
midi_patch
        (ResolvedInstrument -> m (Patch, Config))
-> m ResolvedInstrument -> m (Patch, Config)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Instrument -> m ResolvedInstrument
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 = m (Maybe Backend)
-> (Backend -> m (Maybe Config)) -> m (Maybe Config)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (Instrument -> m (Maybe Backend)
forall (m :: * -> *). M m => Instrument -> m (Maybe Backend)
lookup_backend Instrument
inst) ((Backend -> m (Maybe Config)) -> m (Maybe Config))
-> (Backend -> m (Maybe Config)) -> m (Maybe Config)
forall a b. (a -> b) -> a -> b
$ \case
    Midi Patch
_ Config
config -> Maybe Config -> m (Maybe Config)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Config -> m (Maybe Config))
-> Maybe Config -> m (Maybe Config)
forall a b. (a -> b) -> a -> b
$ Config -> Maybe Config
forall a. a -> Maybe a
Just Config
config
    Backend
_ -> Maybe Config -> m (Maybe Config)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Config
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 = m (Maybe ResolvedInstrument)
-> (ResolvedInstrument -> m (Maybe Backend)) -> m (Maybe Backend)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (Instrument -> m (Maybe ResolvedInstrument)
forall (m :: * -> *).
M m =>
Instrument -> m (Maybe ResolvedInstrument)
lookup_instrument Instrument
inst) ((ResolvedInstrument -> m (Maybe Backend)) -> m (Maybe Backend))
-> (ResolvedInstrument -> m (Maybe Backend)) -> m (Maybe Backend)
forall a b. (a -> b) -> a -> b
$
    Maybe Backend -> m (Maybe Backend)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Backend -> m (Maybe Backend))
-> (ResolvedInstrument -> Maybe Backend)
-> ResolvedInstrument
-> m (Maybe Backend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Backend -> Maybe Backend
forall a. a -> Maybe a
Just (Backend -> Maybe Backend)
-> (ResolvedInstrument -> Backend)
-> ResolvedInstrument
-> Maybe Backend
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 <- m State
forall (m :: * -> *). M m => m State
Ui.get
    InstrumentDb
db <- (State -> InstrumentDb) -> m InstrumentDb
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets ((State -> InstrumentDb) -> m InstrumentDb)
-> (State -> InstrumentDb) -> m InstrumentDb
forall a b. (a -> b) -> a -> b
$ Config -> InstrumentDb
config_instrument_db (Config -> InstrumentDb)
-> (State -> Config) -> State -> InstrumentDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
state_config
    case Instrument -> Lens State (Maybe Allocation)
Ui.allocation Instrument
inst Lens State (Maybe Allocation) -> State -> Maybe Allocation
forall f a. Lens f a -> f -> a
#$ State
ui_state of
        Maybe Allocation
Nothing -> Maybe ResolvedInstrument -> m (Maybe ResolvedInstrument)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ResolvedInstrument
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.
                Text -> m ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"lookup " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
                Maybe ResolvedInstrument -> m (Maybe ResolvedInstrument)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ResolvedInstrument
forall a. Maybe a
Nothing
            Right ResolvedInstrument
val -> Maybe ResolvedInstrument -> m (Maybe ResolvedInstrument)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedInstrument -> Maybe ResolvedInstrument
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 = Text -> Maybe ResolvedInstrument -> m ResolvedInstrument
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"instrument not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst)
    (Maybe ResolvedInstrument -> m ResolvedInstrument)
-> m (Maybe ResolvedInstrument) -> m ResolvedInstrument
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Instrument -> m (Maybe ResolvedInstrument)
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 = ((Instrument -> Either Text ResolvedInstrument)
 -> Instrument -> Maybe ResolvedInstrument)
-> m (Instrument -> Either Text ResolvedInstrument)
-> m (Instrument -> Maybe ResolvedInstrument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Maybe ResolvedInstrument)
-> (ResolvedInstrument -> Maybe ResolvedInstrument)
-> Either Text ResolvedInstrument
-> Maybe ResolvedInstrument
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ResolvedInstrument -> Text -> Maybe ResolvedInstrument
forall a b. a -> b -> a
const Maybe ResolvedInstrument
forall a. Maybe a
Nothing) ResolvedInstrument -> Maybe ResolvedInstrument
forall a. a -> Maybe a
Just .) (m (Instrument -> Either Text ResolvedInstrument)
 -> m (Instrument -> Maybe ResolvedInstrument))
-> m (Instrument -> Either Text ResolvedInstrument)
-> m (Instrument -> Maybe ResolvedInstrument)
forall a b. (a -> b) -> a -> b
$
    State -> State -> Instrument -> Either Text ResolvedInstrument
state_lookup_instrument (State -> State -> Instrument -> Either Text ResolvedInstrument)
-> m State
-> m (State -> Instrument -> Either Text ResolvedInstrument)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m State
forall (m :: * -> *). M m => m State
Ui.get m (State -> Instrument -> Either Text ResolvedInstrument)
-> m State -> m (Instrument -> Either Text ResolvedInstrument)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m State
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 ->
    Either Text ResolvedInstrument
-> Maybe (Either Text ResolvedInstrument)
-> Either Text ResolvedInstrument
forall a. a -> Maybe a -> a
fromMaybe (Text -> Either Text ResolvedInstrument
forall a b. a -> Either a b
Left (Text -> Either Text ResolvedInstrument)
-> Text -> Either Text ResolvedInstrument
forall a b. (a -> b) -> a -> b
$ Text
"no alloc for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst) (Maybe (Either Text ResolvedInstrument)
 -> Either Text ResolvedInstrument)
-> Maybe (Either Text ResolvedInstrument)
-> Either Text ResolvedInstrument
forall a b. (a -> b) -> a -> b
$ Instrument
-> Map Instrument (Either Text ResolvedInstrument)
-> Maybe (Either Text ResolvedInstrument)
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 (Allocation -> Either Text ResolvedInstrument)
-> Map Instrument Allocation
-> Map Instrument (Either Text ResolvedInstrument)
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 InstrumentCode
inst <- Text
-> Maybe (Inst InstrumentCode) -> Either Text (Inst InstrumentCode)
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"patch not in db: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Qualified -> Text
forall a. Pretty a => a -> Text
pretty Qualified
qualified) (Maybe (Inst InstrumentCode) -> Either Text (Inst InstrumentCode))
-> Maybe (Inst InstrumentCode) -> Either Text (Inst InstrumentCode)
forall a b. (a -> b) -> a -> b
$
        Qualified -> InstrumentDb -> Maybe (Inst InstrumentCode)
inst_lookup Qualified
qualified InstrumentDb
db
    Backend
backend <- case (Inst InstrumentCode -> Backend
forall code. Inst code -> Backend
Inst.inst_backend Inst InstrumentCode
inst, Allocation -> Backend
UiConfig.alloc_backend Allocation
alloc) of
        (Inst.Midi Patch
patch, UiConfig.Midi Config
config) ->
            Backend -> Either Text Backend
forall (m :: * -> *) a. Monad m => a -> m a
return (Backend -> Either Text Backend) -> Backend -> Either Text Backend
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) -> Backend -> Either Text Backend
forall (m :: * -> *) a. Monad m => a -> m a
return (Backend -> Either Text Backend) -> Backend -> Either Text Backend
forall a b. (a -> b) -> a -> b
$ Patch -> Backend
Im Patch
patch
        (Inst.Sc Patch
patch, Backend
UiConfig.Sc) -> Backend -> Either Text Backend
forall (m :: * -> *) a. Monad m => a -> m a
return (Backend -> Either Text Backend) -> Backend -> Either Text Backend
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.
            Backend -> Either Text Backend
forall (m :: * -> *) a. Monad m => a -> m a
return (Backend -> Either Text Backend) -> Backend -> Either Text Backend
forall a b. (a -> b) -> a -> b
$ Text -> Backend
Dummy (Text -> Backend) -> Text -> Backend
forall a b. (a -> b) -> a -> b
$ if Text
msg2 Text -> Text -> Bool
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) -> Text -> Either Text Backend
forall a b. a -> Either a b
Left (Text -> Either Text Backend) -> Text -> Either Text Backend
forall a b. (a -> b) -> a -> b
$
            Text
"inconsistent backends: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Backend, Backend) -> Text
forall a. Pretty a => a -> Text
pretty (Backend
inst_backend, Backend
alloc_backend)
    ResolvedInstrument -> Either Text ResolvedInstrument
forall (m :: * -> *) a. Monad m => a -> m a
return (ResolvedInstrument -> Either Text ResolvedInstrument)
-> ResolvedInstrument -> Either Text ResolvedInstrument
forall a b. (a -> b) -> a -> b
$ ResolvedInstrument
        { inst_instrument :: Inst InstrumentCode
inst_instrument = Backend -> Inst InstrumentCode -> Inst InstrumentCode
forall {code}. Backend -> Inst code -> Inst code
merge_call_map Backend
backend Inst InstrumentCode
inst
        , inst_qualified :: Qualified
inst_qualified = Qualified
qualified
        , inst_common_config :: Config
inst_common_config =
            Common InstrumentCode -> Config -> Config
merge_environ (Inst InstrumentCode -> Common InstrumentCode
forall code. Inst code -> Common code
Inst.inst_common Inst InstrumentCode
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 (Config :-> Environ) -> (Environ -> Environ) -> Config -> Config
forall f a. Lens f a -> (a -> a) -> f -> f
%= (Common InstrumentCode -> Environ
forall code. Common code -> Environ
Common.common_environ Common InstrumentCode
common <>)
    -- 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 =
        Inst code :-> Common code
forall {code}. Inst code :-> Common code
Inst.common(Inst code :-> Common code)
-> Lens (Common code) CallMap -> Lens (Inst code) CallMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens (Common code) CallMap
forall {code}. Common code :-> CallMap
Common.call_map Lens (Inst code) CallMap
-> (CallMap -> CallMap) -> Inst code -> Inst code
forall f a. Lens f a -> (a -> a) -> f -> f
%= (CallMap -> CallMap -> CallMap
forall a. Semigroup a => a -> a -> a
<> [Attributes] -> CallMap
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 = [(a, Symbol)] -> Map a Symbol
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (a
attr, Text -> Symbol
Expr.Symbol (Text -> Symbol) -> Text -> Symbol
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val a
attr)
        | a
attr <- [a]
attrs, a
attr a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
forall a. Monoid a => a
mempty
        ]
    inst_attrs :: Backend -> [Attributes]
inst_attrs = \case
        Midi Patch
patch Config
_ ->
            AttributeMap ([Keyswitch], Maybe Keymap) -> [Attributes]
forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes (AttributeMap ([Keyswitch], Maybe Keymap) -> [Attributes])
-> AttributeMap ([Keyswitch], Maybe Keymap) -> [Attributes]
forall a b. (a -> b) -> a -> b
$ Patch -> AttributeMap ([Keyswitch], Maybe Keymap)
Midi.Patch.patch_attribute_map Patch
patch
        Im Patch
patch ->
            AttributeMap () -> [Attributes]
forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes (AttributeMap () -> [Attributes])
-> AttributeMap () -> [Attributes]
forall a b. (a -> b) -> a -> b
$ Patch -> AttributeMap ()
Im.Patch.patch_attribute_map Patch
patch
        Sc Patch
_patch -> [Attributes]
forall a. Monoid a => a
mempty -- TODO attrs for sc?
        Dummy {} -> [Attributes]
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 InstrumentCode)
get_qualified Qualified
qualified =
    Text -> Maybe (Inst InstrumentCode) -> m (Inst InstrumentCode)
forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
require (Text
"patch not in db: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Qualified -> Text
forall a. Pretty a => a -> Text
pretty Qualified
qualified)
        (Maybe (Inst InstrumentCode) -> m (Inst InstrumentCode))
-> m (Maybe (Inst InstrumentCode)) -> m (Inst InstrumentCode)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Qualified -> m (Maybe (Inst InstrumentCode))
forall (m :: * -> *).
M m =>
Qualified -> m (Maybe (Inst InstrumentCode))
lookup_qualified Qualified
qualified

get_alloc_qualified :: M m => UiConfig.Allocation -> m Inst
get_alloc_qualified :: forall (m :: * -> *). M m => Allocation -> m (Inst InstrumentCode)
get_alloc_qualified = Qualified -> m (Inst InstrumentCode)
forall (m :: * -> *). M m => Qualified -> m (Inst InstrumentCode)
get_qualified (Qualified -> m (Inst InstrumentCode))
-> (Allocation -> Qualified)
-> Allocation
-> m (Inst InstrumentCode)
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 InstrumentCode))
lookup_qualified Qualified
qualified = do
    Config
config <- (State -> Config) -> m Config
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets State -> Config
state_config
    Maybe (Inst InstrumentCode) -> m (Maybe (Inst InstrumentCode))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Inst InstrumentCode) -> m (Maybe (Inst InstrumentCode)))
-> Maybe (Inst InstrumentCode) -> m (Maybe (Inst InstrumentCode))
forall a b. (a -> b) -> a -> b
$ Qualified -> InstrumentDb -> Maybe (Inst InstrumentCode)
inst_lookup Qualified
qualified (Config -> InstrumentDb
config_instrument_db Config
config)

inst_lookup :: InstT.Qualified -> InstrumentDb -> Maybe Inst
inst_lookup :: Qualified -> InstrumentDb -> Maybe (Inst InstrumentCode)
inst_lookup Qualified
qualified InstrumentDb
db
    | Qualified
qualified Qualified -> Qualified -> Bool
forall a. Eq a => a -> a -> Bool
== Qualified
InstT.dummy =
        Inst InstrumentCode -> Maybe (Inst InstrumentCode)
forall a. a -> Maybe a
Just (Inst InstrumentCode -> Maybe (Inst InstrumentCode))
-> Inst InstrumentCode -> Maybe (Inst InstrumentCode)
forall a b. (a -> b) -> a -> b
$ Backend -> Common InstrumentCode -> Inst InstrumentCode
forall code. Backend -> Common code -> Inst code
Inst.Inst (Text -> Backend
Inst.Dummy Text
"") (InstrumentCode -> Common InstrumentCode
forall code. code -> Common code
Common.common InstrumentCode
empty_code)
    | Bool
otherwise = Qualified -> InstrumentDb -> Maybe (Inst InstrumentCode)
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 = (State -> WriteDeviceState) -> m WriteDeviceState
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 = (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
modify ((State -> State) -> m ()) -> (State -> State) -> m ()
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 = (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_derive_immediately :: Set BlockId
state_derive_immediately =
    [BlockId] -> Set BlockId
forall a. Ord a => [a] -> Set a
Set.fromList [BlockId]
block_ids Set BlockId -> Set BlockId -> Set BlockId
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 = (PlayState -> PlayState) -> m ()
forall (m :: * -> *). M m => (PlayState -> PlayState) -> m ()
modify_play_state ((PlayState -> PlayState) -> m ())
-> (PlayState -> PlayState) -> m ()
forall a b. (a -> b) -> a -> b
$ \PlayState
st -> PlayState
st
    { state_current_performance :: Map BlockId Performance
state_current_performance = (Performance -> Performance)
-> Map BlockId Performance -> Map BlockId 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 ScoreDamage -> ScoreDamage -> ScoreDamage
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 = ScoreDamage -> m ()
forall (m :: * -> *). M m => ScoreDamage -> m ()
inflict_damage (ScoreDamage -> m ()) -> ScoreDamage -> m ()
forall a b. (a -> b) -> a -> b
$ ScoreDamage
forall a. Monoid a => a
mempty
    { sdamage_blocks :: Set BlockId
Derive.sdamage_blocks = BlockId -> Set BlockId
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 = ScoreDamage -> m ()
forall (m :: * -> *). M m => ScoreDamage -> m ()
inflict_damage (ScoreDamage -> m ()) -> ScoreDamage -> m ()
forall a b. (a -> b) -> a -> b
$ ScoreDamage
forall a. Monoid a => a
mempty
    { sdamage_tracks :: Map TrackId (Ranges ScoreTime)
Derive.sdamage_tracks = TrackId -> Ranges ScoreTime -> Map TrackId (Ranges ScoreTime)
forall k a. k -> a -> Map k a
Map.singleton TrackId
track_id Ranges ScoreTime
forall n. Ranges n
Ranges.everything
    , sdamage_track_blocks :: Set BlockId
Derive.sdamage_track_blocks = BlockId -> Set BlockId
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 = (State -> State) -> m ()
forall (m :: * -> *). M m => (State -> State) -> m ()
modify ((State -> State) -> m ()) -> (State -> State) -> m ()
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
    (EditState -> EditState) -> m ()
forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state ((EditState -> EditState) -> m ())
-> (EditState -> EditState) -> m ()
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 <- m [BlockId]
forall (m :: * -> *). M m => m [BlockId]
Ui.all_block_ids
    [BlockId] -> (BlockId -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BlockId]
block_ids ((BlockId -> m ()) -> m ()) -> (BlockId -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \BlockId
bid -> BlockId -> Box -> Box -> m ()
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 = (EditMode -> EditMode -> Bool
forall a. Eq a => a -> a -> Bool
== EditMode
ValEdit) (EditMode -> Bool) -> m EditMode -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State -> EditMode) -> m EditMode
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (EditState -> EditMode
state_edit_mode (EditState -> EditMode)
-> (State -> EditState) -> State -> EditMode
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 = (State -> Bool) -> m Bool
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (EditState -> Bool
state_kbd_entry (EditState -> Bool) -> (State -> EditState) -> State -> Bool
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
    (EditState -> EditState) -> m ()
forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state ((EditState -> EditState) -> m ())
-> (EditState -> EditState) -> m ()
forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st { state_note_text :: Text
state_note_text = Text
text }
    (Int, Text) -> Maybe Text -> m ()
forall (m :: * -> *). M m => (Int, Text) -> Maybe Text -> m ()
set_status (Int, Text)
Config.status_note_text (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$
        if Text -> Bool
Text.null Text
text then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
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 = Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe Attributes
forall a. Monoid a => a
mempty (Maybe Attributes -> Attributes)
-> m (Maybe Attributes) -> m Attributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (State -> Maybe Attributes) -> m (Maybe Attributes)
forall (m :: * -> *) a. M m => (State -> a) -> m a
gets (Instrument -> Map Instrument Attributes -> Maybe Attributes
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst (Map Instrument Attributes -> Maybe Attributes)
-> (State -> Map Instrument Attributes)
-> State
-> Maybe Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditState -> Map Instrument Attributes
state_instrument_attributes (EditState -> Map Instrument Attributes)
-> (State -> EditState) -> State -> Map 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 = (EditState -> EditState) -> m ()
forall (m :: * -> *). M m => (EditState -> EditState) -> m ()
modify_edit_state ((EditState -> EditState) -> m ())
-> (EditState -> EditState) -> m ()
forall a b. (a -> b) -> a -> b
$ \EditState
st -> EditState
st
    { state_instrument_attributes :: Map Instrument Attributes
state_instrument_attributes =
        Instrument
-> Attributes
-> Map Instrument Attributes
-> Map 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 m a -> m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (State -> State) -> m ()
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 Text -> [Text] -> [Text]
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 m a -> m () -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (State -> State) -> m ()
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 Text -> [Text] -> [Text]
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 = EditMode -> Maybe EditMode
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 (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
block_id, TrackId -> Maybe TrackId
forall a. a -> Maybe a
Just TrackId
track_id, (ScoreTime, ScoreTime) -> Maybe (ScoreTime, ScoreTime)
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 = (Thru -> m ()) -> [Thru] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Thru -> m ()
forall (m :: * -> *). M m => Thru -> m ()
write_thru
    [ Message -> Thru
MidiThru (Message -> Thru) -> Message -> Thru
forall a b. (a -> b) -> a -> b
$ RealTime -> Message
Midi.Interface.AllNotesOff RealTime
0
    , Message -> Thru
MidiThru (Message -> Thru) -> Message -> Thru
forall a b. (a -> b) -> a -> b
$ RealTime -> Message
Interface.reset_controls RealTime
0
    , Message -> Thru
ImThru Message
Thru.Stop
    ]