{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
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
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
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
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)
}
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
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 Bool Key.Key
| Click Types.MouseButton MouseOn Int
| Drag Types.MouseButton MouseOn
| Release Types.MouseButton MouseOn
| 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)
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
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
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"
type CmdId = CmdT Identity.Identity
type CmdL a = CmdT IO a
data Status =
Continue
| Done
| Play !PlayArgs
| FloatingInput !FloatingInput
| 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)
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
data PlayArgs = PlayArgs {
PlayArgs -> Maybe SyncConfig
play_sync :: !(Maybe SyncConfig)
, 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)
, 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))"
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 =
FloatingOpen !ViewId !TrackNum !ScoreTime !Text !(Int, Int)
| 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)
type RunCmd cmd_m val_m a =
Ui.State -> State -> CmdT cmd_m a -> val_m (Result a)
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
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)
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)
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_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_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
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
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
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
get :: m State
put :: State -> m ()
write_thru :: Thru -> m ()
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 =
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
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
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
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)
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
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
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
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
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
data State = State {
State -> Config
state_config :: !Config
, State -> Maybe (Writable, SaveFile)
state_save_file :: !(Maybe (Writable, SaveFile))
, State -> Saved
state_saved :: !Saved
, State -> Maybe KyCache
state_ky_cache :: !(Maybe KyCache)
, State -> Set BlockId
state_derive_immediately :: !(Set BlockId)
, State -> History
state_history :: !History
, State -> HistoryConfig
state_history_config :: !HistoryConfig
, State -> HistoryCollect
state_history_collect :: !HistoryCollect
, State -> SelectionHistory
state_selection_history :: !SelectionHistory
, State -> Map Modifier Modifier
state_keys_down :: !(Map Modifier Modifier)
, State -> Maybe ViewId
state_focused_view :: !(Maybe ViewId)
, State -> [Rect]
state_screens :: ![Rect.Rect]
, State -> Maybe KeycapsState
state_keycaps :: !(Maybe KeycapsState)
, State -> Maybe KeycapsUpdate
state_keycaps_update :: !(Maybe KeycapsUpdate)
, State -> Map Text Text
state_global_status :: !(Map Text Text)
, State -> PlayState
state_play :: !PlayState
, State -> Hooks
state_hooks :: !Hooks
, State -> WriteDeviceState
state_wdev_state :: !WriteDeviceState
, State -> ReadDeviceState
state_rdev_state :: !InputNote.ReadDeviceState
, State -> EditState
state_edit :: !EditState
, State -> Status
state_repl_status :: !Status
, 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)
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)
data SavedState =
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)
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)
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
score_path :: State -> FilePath
score_path :: State -> String
score_path State
state = case State -> Maybe (Writable, SaveFile)
state_save_file State
state of
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))
data KyCache =
KyCache !(Either Text (Derive.Builtins, Derive.InstrumentAliases))
!Fingerprint
| 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)
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 =
[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
, 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
}
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
, 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) }
, 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) }
}
data Config = Config {
Config -> AppDir
config_app_dir :: !Path.AppDir
, Config -> Canonical
config_save_dir :: !Path.Canonical
, Config -> Interface
config_midi_interface :: !Midi.Interface.Interface
, Config -> [String]
config_ky_paths :: ![FilePath]
, Config -> Map ReadDevice ReadDevice
config_rdev_map :: !(Map Midi.ReadDevice Midi.ReadDevice)
, Config -> Map WriteDevice WriteDevice
config_wdev_map :: !(Map Midi.WriteDevice Midi.WriteDevice)
, Config -> InstrumentDb
config_instrument_db :: !InstrumentDb
, 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
, 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)
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))
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))
lookup_scale :: Derive.LookupScale
lookup_scale :: LookupScale
lookup_scale = LookupScale
Scale.All.lookup_scale
data PlayState = PlayState {
PlayState -> [PlayControl]
state_play_control :: ![Transport.PlayControl]
, PlayState -> Map BlockId Performance
state_performance :: !(Map BlockId Performance)
, PlayState -> Map BlockId Performance
state_current_performance :: !(Map BlockId Performance)
, PlayState -> Map BlockId Thread
state_performance_threads :: !(Map BlockId Thread)
, PlayState -> TimeStep
state_play_step :: !TimeStep.TimeStep
, PlayState -> Maybe StepState
state_step :: !(Maybe StepState)
, PlayState -> RealTime
state_play_multiplier :: RealTime
, PlayState -> Maybe SyncConfig
state_sync :: !(Maybe SyncConfig)
, 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)
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
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
}
data StepState = StepState {
StepState -> ViewId
step_view_id :: !ViewId
, StepState -> [Int]
step_tracknums :: [TrackNum]
, StepState -> [(ScoreTime, State)]
step_before :: ![(ScoreTime, Midi.State.State)]
, 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)
data SyncConfig = SyncConfig {
SyncConfig -> WriteDevice
sync_device :: !Midi.WriteDevice
, SyncConfig -> Channel
sync_device_id :: !Mmc.DeviceId
, 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))
]
newtype Hooks = Hooks {
Hooks -> [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
hooks_selection :: [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
}
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
(<>)
data EditState = EditState {
EditState -> EditMode
state_edit_mode :: !EditMode
, EditState -> Bool
state_floating_input :: !Bool
, EditState -> Bool
state_advance :: Bool
, EditState -> Bool
state_chord :: Bool
, EditState -> Bool
state_record_velocity :: Bool
, EditState -> Bool
state_kbd_entry :: !Bool
, EditState -> TimeStep
state_time_step :: !TimeStep.TimeStep
, EditState -> TimeStep
state_note_duration :: !TimeStep.TimeStep
, EditState -> Orientation
state_note_orientation :: !Types.Orientation
, EditState -> Text
state_note_text :: !Text
, 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)
, 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
""
, 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
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
data Action =
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
data WriteDeviceState = WriteDeviceState {
WriteDeviceState -> Map NoteId Addr
wdev_note_addr :: !(Map InputNote.NoteId Patch.Addr)
, WriteDeviceState -> Map NoteId Key
wdev_note_key :: !(Map InputNote.NoteId Midi.Key)
, WriteDeviceState -> Map Addr Int
wdev_addr_serial :: !(Map Patch.Addr Serial)
, WriteDeviceState -> Int
wdev_serial :: !Serial
, WriteDeviceState -> Maybe NoteId
wdev_last_note_id :: !(Maybe InputNote.NoteId)
, WriteDeviceState -> Map NoteId (BlockId, Int)
wdev_pitch_track :: !(Map InputNote.NoteId (BlockId, TrackNum))
, 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
}
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
data InstrumentCode = InstrumentCode {
InstrumentCode -> InstrumentCalls
inst_calls :: !Derive.InstrumentCalls
, InstrumentCode -> InstrumentPostproc
inst_postproc :: !InstrumentPostproc
, InstrumentCode -> [HandlerId]
inst_cmds :: ![HandlerId]
, InstrumentCode -> Maybe ThruFunction
inst_thru :: !(Maybe ThruFunction)
}
type ThruFunction =
Scale.Scale -> Attrs.Attributes -> InputNote.Input -> CmdId [Thru]
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
}
type InstrumentDb = Inst.Db InstrumentCode
type Inst = Inst.Inst InstrumentCode
data History = History {
History -> [HistoryEntry]
hist_past :: ![HistoryEntry]
, 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
data LastCmd =
UndoRedo
| 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 {
HistoryConfig -> Int
hist_keep :: !Int
, 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 {
HistoryCollect -> [Text]
state_cmd_names :: ![Text]
, HistoryCollect -> Maybe EditMode
state_suppress_edit :: !(Maybe EditMode)
, 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
, HistoryEntry -> UiDamage
hist_damage :: !Update.UiDamage
, HistoryEntry -> [Text]
hist_names :: ![Text]
, 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)
]
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)
]
data Modifier = KeyMod Key.Modifier
| MouseMod Types.MouseButton (Maybe (TrackNum, UiMsg.Track))
| 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
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
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) }
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
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
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_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
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
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
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_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)
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
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_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
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)
]
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
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
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))
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
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) ->
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
(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_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 <>)
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
Dummy {} -> [Attributes]
forall a. Monoid a => a
mempty
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
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
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 }
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 }
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
}
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) }
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)
}
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) }
})
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_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))
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
]