-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} {- | Core CmdT monad that cmds run in. A Cmd is what user actions turn into. The main thing they do is edit 'Ui.State', or Cmd.'State', but a special subset can also do IO actions like saving and loading files. The Cmd monad has two kinds of exception: abort or throw. Abort means that the Cmd decided that it's not the proper Cmd for this Msg (keystroke, mouse movement, whatever) and another Cmd should get a crack at it. Throw means that the Cmd failed and there is nothing to be done but log an error. When an exception is thrown, the ui and cmd states are rolled back and midi output is discarded. Cmds should be in the monad @Cmd.M m => m ...@. They have to be polymorphic because they run in both IO and Identity. IO because some cmds such saving and loading files require IO, and Identity because the majority of cmds don't. REPL cmds run in IO so they can load and save, and the result is that any cmd that wants to be used from both Identity cmds (bound to keystrokes) and the REPL must be polymorphic in the monad. Previously I used @M@ instead of @Monad m => CmdT m ...@ to establish Functor, but post-AMP I don't need that any more. But to maintain consistency I'll keep using @M@. -} module Cmd.Cmd ( module Cmd.Cmd, Performance(..) ) where import qualified Control.Concurrent.Async as Async import qualified Control.Exception as Exception import qualified Control.Monad.Except as Except import qualified Control.Monad.Identity as Identity import qualified Control.Monad.State.Strict as MonadState import qualified Control.Monad.Trans as Trans import qualified Data.Hashable as Hashable import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Text as Text import qualified System.Directory as Directory import qualified System.FilePath as FilePath import qualified Vivid.OSC as OSC import qualified Util.CallStack as CallStack import qualified Util.Exceptions as Exceptions import qualified Util.GitT as GitT import qualified Util.Lists as Lists import qualified Util.Log as Log import qualified Util.Logger as Logger import qualified Util.Pretty as Pretty import qualified Util.Ranges as Ranges import qualified Util.Rect as Rect import qualified Util.Texts as Texts import qualified App.Config as Config import qualified App.Path as Path import qualified Cmd.InputNote as InputNote import qualified Cmd.Msg as Msg import Cmd.Msg (Performance(..)) import qualified Cmd.SaveGitT as SaveGitT import qualified Cmd.TimeStep as TimeStep import qualified Derive.Attrs as Attrs import qualified Derive.Derive as Derive import qualified Derive.Expr as Expr import qualified Derive.Parse.Ky as Ky import qualified Derive.ParseTitle as ParseTitle import qualified Derive.REnv as REnv import qualified Derive.Scale as Scale import qualified Derive.Scale.All as Scale.All import qualified Derive.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Derive.ShowVal as ShowVal import qualified Derive.Stack as Stack import qualified Derive.TrackWarp as TrackWarp import qualified Instrument.Common as Common import qualified Instrument.Inst as Inst import qualified Instrument.InstT as InstT import qualified Midi.Interface import qualified Midi.Interface as Interface import qualified Midi.Midi as Midi import qualified Midi.Mmc as Mmc import qualified Midi.State import qualified Perform.Im.Patch as Im.Patch import qualified Perform.Midi.Patch as Midi.Patch import qualified Perform.Midi.Patch as Patch import qualified Perform.Midi.Perform as Midi.Perform import qualified Perform.Midi.Types as Midi.Types import qualified Perform.Pitch as Pitch import qualified Perform.RealTime as RealTime import qualified Perform.Sc.Note as Sc.Note import qualified Perform.Sc.Patch as Sc.Patch import qualified Perform.Transport as Transport import qualified Synth.Shared.Config as Shared.Config import qualified Synth.Shared.Thru as Thru import qualified Ui.Block as Block import qualified Ui.Color as Color import qualified Ui.Event as Event import qualified Ui.Key as Key import qualified Ui.KeycapsT as KeycapsT import qualified Ui.Meter.Meter as Meter import qualified Ui.Sel as Sel import qualified Ui.Types as Types import qualified Ui.Ui as Ui import qualified Ui.UiConfig as UiConfig import qualified Ui.UiMsg as UiMsg import qualified Ui.Update as Update import Global import Types -- * Handler -- | This is the toplevel object representing a cmd. Fundamentally it's -- just Msg -> Status, but it's also wrapped up in some documentation, -- so cmds can be introspected. data Handler m = Keymap !(Keymap m) | Handler !(Maybe (NoteEntryMap KeycapsT.KeyDoc)) !(NamedCmd m) type HandlerId = Handler CmdId handler :: Text -> (Msg.Msg -> m Status) -> Handler m handler :: forall (m :: * -> *). Text -> (Msg -> m Status) -> Handler m handler Text name Msg -> m Status cmd = forall (m :: * -> *). Maybe (NoteEntryMap Text) -> NamedCmd m -> Handler m Handler forall a. Maybe a Nothing (forall (m :: * -> *). Text -> (Msg -> m Status) -> NamedCmd m NamedCmd Text name Msg -> m Status cmd) call :: M m => Handler m -> Msg.Msg -> m Status call :: forall (m :: * -> *). M m => Handler m -> Msg -> m Status call Handler m handler = \Msg msg -> let run :: NamedCmd m -> m Status run (NamedCmd Text n Msg -> m Status cmd) = do forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.debug forall a b. (a -> b) -> a -> b $ Text "running command: " forall a. Semigroup a => a -> a -> a <> Text n forall (m :: * -> *) a. M m => Text -> m a -> m a name Text n (Msg -> m Status cmd Msg msg) in case Handler m handler of Handler Maybe (NoteEntryMap Text) _ NamedCmd m cmd -> forall {m :: * -> *}. M m => NamedCmd m -> m Status run NamedCmd m cmd Keymap Keymap m keymap -> do Bindable bindable <- forall (m :: * -> *) a. M m => Maybe a -> m a abort_unless (Msg -> Maybe Bindable msg_to_bindable Msg msg) Set Modifier mods <- forall (m :: * -> *). M m => m (Set Modifier) mods_down forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return Status Continue) forall {m :: * -> *}. M m => NamedCmd m -> m Status run forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup (Set Modifier -> Bindable -> KeySpec KeySpec Set Modifier mods Bindable bindable) Keymap m keymap -- | Return the mods currently down, stripping out non-modifier keys and notes, -- so that overlapping keys will still match. Mouse mods are not filtered, so -- each mouse chord can be bound individually. mods_down :: M m => m (Set Modifier) mods_down :: forall (m :: * -> *). M m => m (Set Modifier) mods_down = forall a. Ord a => [a] -> Set a Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a. (a -> Bool) -> [a] -> [a] filter Modifier -> Bool is_mod forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [k] Map.keys) forall (m :: * -> *). M m => m (Map Modifier Modifier) keys_down where is_mod :: Modifier -> Bool is_mod (KeyMod {}) = Bool True is_mod (MidiMod {}) = Bool False is_mod (MouseMod {}) = Bool True -- | Pair a Cmd with a Doc that can be used for logging, undo, etc. data NamedCmd m = NamedCmd { forall (m :: * -> *). NamedCmd m -> Text cmd_name :: !Text , forall (m :: * -> *). NamedCmd m -> Msg -> m Status cmd_call :: !(Msg.Msg -> m Status) } -- | NoteEntry might depend on base octave, and might have different -- mappings for unshifted or shifted. data NoteEntryMap a = WithOctave (Map Pitch.Octave (Map Char a)) | WithoutOctave (Map Char a) deriving (Int -> NoteEntryMap a -> ShowS forall a. Show a => Int -> NoteEntryMap a -> ShowS forall a. Show a => [NoteEntryMap a] -> ShowS forall a. Show a => NoteEntryMap a -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [NoteEntryMap a] -> ShowS $cshowList :: forall a. Show a => [NoteEntryMap a] -> ShowS show :: NoteEntryMap a -> String $cshow :: forall a. Show a => NoteEntryMap a -> String showsPrec :: Int -> NoteEntryMap a -> ShowS $cshowsPrec :: forall a. Show a => Int -> NoteEntryMap a -> ShowS Show, forall a b. a -> NoteEntryMap b -> NoteEntryMap a forall a b. (a -> b) -> NoteEntryMap a -> NoteEntryMap b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: forall a b. a -> NoteEntryMap b -> NoteEntryMap a $c<$ :: forall a b. a -> NoteEntryMap b -> NoteEntryMap a fmap :: forall a b. (a -> b) -> NoteEntryMap a -> NoteEntryMap b $cfmap :: forall a b. (a -> b) -> NoteEntryMap a -> NoteEntryMap b Functor) note_entry_lookup :: Pitch.Octave -> Char -> NoteEntryMap a -> Maybe a note_entry_lookup :: forall a. Int -> Char -> NoteEntryMap a -> Maybe a note_entry_lookup Int octave Char char = \case WithOctave Map Int (Map Char a) m -> forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Char char forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Int octave Map Int (Map Char a) m WithoutOctave Map Char a m -> forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Char char Map Char a m -- ** Keymap type Keymap m = Map KeySpec (NamedCmd m) data KeySpec = KeySpec !(Set Modifier) !Bindable deriving (KeySpec -> KeySpec -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: KeySpec -> KeySpec -> Bool $c/= :: KeySpec -> KeySpec -> Bool == :: KeySpec -> KeySpec -> Bool $c== :: KeySpec -> KeySpec -> Bool Eq, Eq KeySpec KeySpec -> KeySpec -> Bool KeySpec -> KeySpec -> Ordering KeySpec -> KeySpec -> KeySpec forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: KeySpec -> KeySpec -> KeySpec $cmin :: KeySpec -> KeySpec -> KeySpec max :: KeySpec -> KeySpec -> KeySpec $cmax :: KeySpec -> KeySpec -> KeySpec >= :: KeySpec -> KeySpec -> Bool $c>= :: KeySpec -> KeySpec -> Bool > :: KeySpec -> KeySpec -> Bool $c> :: KeySpec -> KeySpec -> Bool <= :: KeySpec -> KeySpec -> Bool $c<= :: KeySpec -> KeySpec -> Bool < :: KeySpec -> KeySpec -> Bool $c< :: KeySpec -> KeySpec -> Bool compare :: KeySpec -> KeySpec -> Ordering $ccompare :: KeySpec -> KeySpec -> Ordering Ord, Int -> KeySpec -> ShowS [KeySpec] -> ShowS KeySpec -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [KeySpec] -> ShowS $cshowList :: [KeySpec] -> ShowS show :: KeySpec -> String $cshow :: KeySpec -> String showsPrec :: Int -> KeySpec -> ShowS $cshowsPrec :: Int -> KeySpec -> ShowS Show) data Bindable = -- | Key IsRepeat Key Key Bool Key.Key -- | Click MouseButton Clicks | Click Types.MouseButton MouseOn Int | Drag Types.MouseButton MouseOn -- | Mouse button release. | Release Types.MouseButton MouseOn -- | Channel can be used to restrict bindings to a certain keyboard. This -- should probably be something more abstract though, such as a device -- which can be set by the static config. | Note Midi.Channel Midi.Key deriving (Bindable -> Bindable -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Bindable -> Bindable -> Bool $c/= :: Bindable -> Bindable -> Bool == :: Bindable -> Bindable -> Bool $c== :: Bindable -> Bindable -> Bool Eq, Eq Bindable Bindable -> Bindable -> Bool Bindable -> Bindable -> Ordering Bindable -> Bindable -> Bindable forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Bindable -> Bindable -> Bindable $cmin :: Bindable -> Bindable -> Bindable max :: Bindable -> Bindable -> Bindable $cmax :: Bindable -> Bindable -> Bindable >= :: Bindable -> Bindable -> Bool $c>= :: Bindable -> Bindable -> Bool > :: Bindable -> Bindable -> Bool $c> :: Bindable -> Bindable -> Bool <= :: Bindable -> Bindable -> Bool $c<= :: Bindable -> Bindable -> Bool < :: Bindable -> Bindable -> Bool $c< :: Bindable -> Bindable -> Bool compare :: Bindable -> Bindable -> Ordering $ccompare :: Bindable -> Bindable -> Ordering Ord, Int -> Bindable -> ShowS [Bindable] -> ShowS Bindable -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Bindable] -> ShowS $cshowList :: [Bindable] -> ShowS show :: Bindable -> String $cshow :: Bindable -> String showsPrec :: Int -> Bindable -> ShowS $cshowsPrec :: Int -> Bindable -> ShowS Show) -- | Where a click or drag occurred. data MouseOn = OnTrack | OnDivider | OnSkeleton | Elsewhere deriving (MouseOn -> MouseOn -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: MouseOn -> MouseOn -> Bool $c/= :: MouseOn -> MouseOn -> Bool == :: MouseOn -> MouseOn -> Bool $c== :: MouseOn -> MouseOn -> Bool Eq, Eq MouseOn MouseOn -> MouseOn -> Bool MouseOn -> MouseOn -> Ordering MouseOn -> MouseOn -> MouseOn forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: MouseOn -> MouseOn -> MouseOn $cmin :: MouseOn -> MouseOn -> MouseOn max :: MouseOn -> MouseOn -> MouseOn $cmax :: MouseOn -> MouseOn -> MouseOn >= :: MouseOn -> MouseOn -> Bool $c>= :: MouseOn -> MouseOn -> Bool > :: MouseOn -> MouseOn -> Bool $c> :: MouseOn -> MouseOn -> Bool <= :: MouseOn -> MouseOn -> Bool $c<= :: MouseOn -> MouseOn -> Bool < :: MouseOn -> MouseOn -> Bool $c< :: MouseOn -> MouseOn -> Bool compare :: MouseOn -> MouseOn -> Ordering $ccompare :: MouseOn -> MouseOn -> Ordering Ord, Int -> MouseOn -> ShowS [MouseOn] -> ShowS MouseOn -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [MouseOn] -> ShowS $cshowList :: [MouseOn] -> ShowS show :: MouseOn -> String $cshow :: MouseOn -> String showsPrec :: Int -> MouseOn -> ShowS $cshowsPrec :: Int -> MouseOn -> ShowS Show) msg_to_bindable :: Msg.Msg -> Maybe Bindable msg_to_bindable :: Msg -> Maybe Bindable msg_to_bindable Msg msg = case Msg msg of (Msg -> Maybe (Bool, Key) get_key -> Just (Bool is_repeat, Key key)) -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Bool -> Key -> Bindable Key Bool is_repeat Key key (Msg -> Maybe MouseEvent Msg.mouse -> Just MouseEvent mouse) -> case MouseEvent -> MouseState UiMsg.mouse_state MouseEvent mouse of UiMsg.MouseDown Int btn -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Int -> MouseOn -> Int -> Bindable Click Int btn MouseOn on (MouseEvent -> Int UiMsg.mouse_clicks MouseEvent mouse) UiMsg.MouseDrag Int btn -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Int -> MouseOn -> Bindable Drag Int btn MouseOn on UiMsg.MouseUp Int btn -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Int -> MouseOn -> Bindable Release Int btn MouseOn on MouseState _ -> forall a. Maybe a Nothing (Msg -> Maybe Message Msg.midi -> Just (Midi.ChannelMessage Channel chan (Midi.NoteOn Key key Channel _))) -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Channel -> Key -> Bindable Note Channel chan Key key Msg _ -> forall a. Maybe a Nothing where on :: MouseOn on = forall b a. b -> (a -> b) -> Maybe a -> b maybe MouseOn Elsewhere Context -> MouseOn mouse_on (Msg -> Maybe Context Msg.context Msg msg) get_key :: Msg -> Maybe (Bool, Key) get_key Msg msg = case Msg -> Maybe (KbdState, Key) Msg.key Msg msg of Just (KbdState UiMsg.KeyDown, Key k) -> forall a. a -> Maybe a Just (Bool False, Key k) Just (KbdState UiMsg.KeyRepeat, Key k) -> forall a. a -> Maybe a Just (Bool True, Key k) Maybe (KbdState, Key) _ -> forall a. Maybe a Nothing mouse_on :: UiMsg.Context -> MouseOn mouse_on :: Context -> MouseOn mouse_on = forall b a. b -> (a -> b) -> Maybe a -> b maybe MouseOn Elsewhere forall {a}. (a, Track) -> MouseOn on forall b c a. (b -> c) -> (a -> b) -> a -> c . Context -> Maybe (Int, Track) UiMsg.ctx_track where on :: (a, Track) -> MouseOn on (a _, UiMsg.Track {}) = MouseOn OnTrack on (a _, Track UiMsg.Divider) = MouseOn OnDivider on (a _, Track UiMsg.SkeletonDisplay) = MouseOn OnSkeleton -- ** pretty instances instance Pretty (Handler m) where format :: Handler m -> Doc format = \case Handler Maybe (NoteEntryMap Text) _ NamedCmd m cmd -> forall a. Pretty a => a -> Doc Pretty.format NamedCmd m cmd Keymap Keymap m keymap -> forall a. Pretty a => a -> Doc Pretty.format Keymap m keymap instance Pretty (NamedCmd m) where pretty :: NamedCmd m -> Text pretty (NamedCmd Text name Msg -> m Status _) = Text "cmd:" forall a. Semigroup a => a -> a -> a <> Text name instance Pretty KeySpec where pretty :: KeySpec -> Text pretty (KeySpec Set Modifier mods Bindable bindable) = forall a. Textlike a => a -> a -> a -> a Texts.join2 Text " " (Set Modifier -> Text show_mods Set Modifier mods) (Bool -> Bindable -> Text show_bindable Bool True Bindable bindable) where show_mods :: Set Modifier -> Text show_mods = Text -> [Text] -> Text Text.intercalate Text " + " forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map Modifier -> Text show_mod forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Set a -> [a] Set.toList show_mod :: Modifier -> Text show_mod :: Modifier -> Text show_mod Modifier m = case Modifier m of -- TODO this is only true on OS X KeyMod Modifier mod -> Modifier -> Text Key.show_mac_mod Modifier mod MouseMod Int button Maybe (Int, Track) _ -> Text "mouse " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int button MidiMod Channel chan Key key -> Text "midi " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Key key forall a. Semigroup a => a -> a -> a <> Text " chan " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Channel chan instance Pretty Bindable where pretty :: Bindable -> Text pretty = Bool -> Bindable -> Text show_bindable Bool True show_bindable :: Bool -> Bindable -> Text show_bindable :: Bool -> Bindable -> Text show_bindable Bool show_repeatable Bindable b = case Bindable b of Key Bool is_repeat Key key -> forall a. Pretty a => a -> Text pretty Key key forall a. Semigroup a => a -> a -> a <> if Bool show_repeatable Bool -> Bool -> Bool && Bool is_repeat then Text " (repeatable)" else Text "" Click Int button MouseOn on Int times -> forall {a}. (Eq a, Num a, Show a) => a -> Text click_times Int times forall a. Semigroup a => a -> a -> a <> Text "click " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int button forall a. Semigroup a => a -> a -> a <> Text " on " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty MouseOn on Drag Int button MouseOn on -> Text "drag " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int button forall a. Semigroup a => a -> a -> a <> Text " on " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty MouseOn on Release Int button MouseOn on -> Text "release " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Int button forall a. Semigroup a => a -> a -> a <> Text " on " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty MouseOn on Note Channel chan Key key -> Text "midi " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Key key forall a. Semigroup a => a -> a -> a <> Text " channel " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt Channel chan where click_times :: a -> Text click_times a 0 = Text "" click_times a 1 = Text "double-" click_times a 2 = Text "triple-" click_times a n = forall a. Show a => a -> Text showt a n forall a. Semigroup a => a -> a -> a <> Text "-" instance Pretty MouseOn where pretty :: MouseOn -> Text pretty MouseOn OnTrack = Text "track" pretty MouseOn OnDivider = Text "divider" pretty MouseOn OnSkeleton = Text "skeleton" pretty MouseOn Elsewhere = Text "elsewhere" -- * run CmdT type CmdId = CmdT Identity.Identity -- | Cmds used by the REPL, which all run in IO. type CmdL a = CmdT IO a data Status = -- | Continue processing, so another Cmd will have an opportunity to see -- the Msg. Continue -- | Stop further cmd processing, \"consuming\" the Msg. | Done -- | Hack to control import dependencies, see "Cmd.PlayC". | Play !PlayArgs -- | Open a FloatingInput box. | FloatingInput !FloatingInput -- | Pack it up and go home. | Quit deriving (Int -> Status -> ShowS [Status] -> ShowS Status -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Status] -> ShowS $cshowList :: [Status] -> ShowS show :: Status -> String $cshow :: Status -> String showsPrec :: Int -> Status -> ShowS $cshowsPrec :: Int -> Status -> ShowS Show) -- | Combine two Statuses by keeping the one with higher priority. -- Yes, Status could be a Monoid but merge should be a rare operation. merge_status :: Status -> Status -> Status merge_status :: Status -> Status -> Status merge_status Status s1 Status s2 = if forall {a}. Num a => Status -> a prio Status s1 forall a. Ord a => a -> a -> Bool >= forall {a}. Num a => Status -> a prio Status s2 then Status s1 else Status s2 where prio :: Status -> a prio Status status = case Status status of Status Continue -> a 0 Status Done -> a 1 Play {} -> a 2 FloatingInput {} -> a 3 Status Quit -> a 4 -- | Arguments for 'Cmd.PlayC.play'. This is a special return value to trigger -- a play, see "Cmd.PlayC" for details. data PlayArgs = PlayArgs { PlayArgs -> Maybe SyncConfig play_sync :: !(Maybe SyncConfig) -- | Description of what is being played for logging. , PlayArgs -> Text play_name :: !Text , PlayArgs -> MidiEvents play_midi :: !Midi.Perform.MidiEvents , PlayArgs -> PlayNotes play_sc :: !Sc.Note.PlayNotes , PlayArgs -> Maybe InverseTempoFunction play_inv_tempo :: !(Maybe Transport.InverseTempoFunction) , PlayArgs -> Maybe RealTime play_repeat_at :: !(Maybe RealTime) -- | Since im playback is done by the VST, I don't directly control it as I -- do with the MIDI player, effectively all the sound is "in the decay." So -- I have an explicit end, and the MIDI thread will pretend it's still -- playing until it crosses this boundary. , PlayArgs -> Maybe RealTime play_im_end :: !(Maybe RealTime) , PlayArgs -> Maybe PlayDirectArgs play_im_direct :: !(Maybe PlayDirectArgs) } instance Show PlayArgs where show :: PlayArgs -> String show PlayArgs _ = String "((PlayArgs))" -- | Arguments for 'Cmd.PlayC.play_im_direct_thread'. data PlayDirectArgs = PlayDirectArgs { PlayDirectArgs -> String play_score_path :: FilePath , PlayDirectArgs -> BlockId play_block_id :: BlockId , PlayDirectArgs -> Set Instrument play_muted :: Set ScoreT.Instrument , PlayDirectArgs -> RealTime play_start :: RealTime } deriving (PlayDirectArgs -> PlayDirectArgs -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: PlayDirectArgs -> PlayDirectArgs -> Bool $c/= :: PlayDirectArgs -> PlayDirectArgs -> Bool == :: PlayDirectArgs -> PlayDirectArgs -> Bool $c== :: PlayDirectArgs -> PlayDirectArgs -> Bool Eq, Int -> PlayDirectArgs -> ShowS [PlayDirectArgs] -> ShowS PlayDirectArgs -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PlayDirectArgs] -> ShowS $cshowList :: [PlayDirectArgs] -> ShowS show :: PlayDirectArgs -> String $cshow :: PlayDirectArgs -> String showsPrec :: Int -> PlayDirectArgs -> ShowS $cshowsPrec :: Int -> PlayDirectArgs -> ShowS Show) data FloatingInput = -- | Open a new floating text input. -- View, track, pos, (select start, select end). FloatingOpen !ViewId !TrackNum !ScoreTime !Text !(Int, Int) -- | Insert the given text into an already open edit box. | FloatingInsert !Text deriving (Int -> FloatingInput -> ShowS [FloatingInput] -> ShowS FloatingInput -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [FloatingInput] -> ShowS $cshowList :: [FloatingInput] -> ShowS show :: FloatingInput -> String $cshow :: FloatingInput -> String showsPrec :: Int -> FloatingInput -> ShowS $cshowsPrec :: Int -> FloatingInput -> ShowS Show) -- | Cmds can run in either Identity or IO, but are generally returned in IO, -- just to make things uniform. type RunCmd cmd_m val_m a = Ui.State -> State -> CmdT cmd_m a -> val_m (Result a) -- | The result of running a Cmd. type Result a = ( State , [Thru] , [Log.Msg] , Either Ui.Error (a, Ui.State, Update.UiDamage) ) run :: Monad m => a -> RunCmd m m a run :: forall (m :: * -> *) a. Monad m => a -> RunCmd m m a run a abort_val State ustate State cstate CmdT m a cmd = do (((Either Error (a, State, UiDamage) ui_result, State cstate2), [Thru] midi), [Msg] logs) <- (forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg]) Log.run forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w]) Logger.run forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b c. (a -> b -> c) -> b -> a -> c flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s) MonadState.runStateT State cstate forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. Monad m => State -> StateT m a -> m (Either Error (a, State, UiDamage)) Ui.run State ustate forall b c a. (b -> c) -> (a -> b) -> a -> c . (\(CmdT StateT (StateT State (LoggerT Thru (LogT m))) a m) -> StateT (StateT State (LoggerT Thru (LogT m))) a m)) CmdT m a cmd -- Any kind of error rolls back state and discards midi, but not log msgs. -- Normally 'abort_val' will be Continue, but obviously if 'cmd' doesn't -- return Status it can't be. forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ case Either Error (a, State, UiDamage) ui_result of Left Error Ui.Abort -> (State cstate, [], [Msg] logs, forall a b. b -> Either a b Right (a abort_val, State ustate, forall a. Monoid a => a mempty)) Left Error _ -> (State cstate, [], [Msg] logs, Either Error (a, State, UiDamage) ui_result) Either Error (a, State, UiDamage) _ -> (State cstate2, [Thru] midi, [Msg] logs, Either Error (a, State, UiDamage) ui_result) -- | Like 'run', but discard MIDI thru and updates. run_ :: Monad m => Ui.State -> State -> CmdT m a -> m (Either String (a, State, Ui.State), [Log.Msg]) run_ :: forall (m :: * -> *) a. Monad m => State -> State -> CmdT m a -> m (Either String (a, State, State), [Msg]) run_ State ui_state State cmd_state CmdT m a cmd = do (State cmd_state, [Thru] _thru, [Msg] logs, Either Error (Maybe a, State, UiDamage) result) <- forall (m :: * -> *) a. Monad m => a -> RunCmd m m a run forall a. Maybe a Nothing State ui_state State cmd_state (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM forall a. a -> Maybe a Just CmdT m a cmd) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ (, [Msg] logs) forall a b. (a -> b) -> a -> b $ case Either Error (Maybe a, State, UiDamage) result of Left Error err -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ forall a. Pretty a => a -> String prettys Error err Right (Maybe a val, State ui_state, UiDamage _damage) -> case Maybe a val of Maybe a Nothing -> forall a b. a -> Either a b Left String "aborted" Just a v -> forall a b. b -> Either a b Right (a v, State cmd_state, State ui_state) -- | Like 'run_', but discard all the final states. eval :: Monad m => Ui.State -> State -> CmdT m a -> m (Either String a, [Log.Msg]) eval :: forall (m :: * -> *) a. Monad m => State -> State -> CmdT m a -> m (Either String a, [Msg]) eval State ui_state State cmd_state = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second forall {a} {b} {c}. (a, b, c) -> a val_of)) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. Monad m => State -> State -> CmdT m a -> m (Either String (a, State, State), [Msg]) run_ State ui_state State cmd_state where val_of :: (a, b, c) -> a val_of (a a, b _, c _) = a a -- | Run the Cmd in Identity, returning Nothing if it aborted. run_id :: Ui.State -> State -> CmdT Identity.Identity a -> Result (Maybe a) run_id :: forall a. State -> State -> CmdT Identity a -> Result (Maybe a) run_id State ui_state State cmd_state CmdT Identity a cmd = forall a. Identity a -> a Identity.runIdentity (forall (m :: * -> *) a. Monad m => a -> RunCmd m m a run forall a. Maybe a Nothing State ui_state State cmd_state (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. a -> Maybe a Just CmdT Identity a cmd)) -- | Run the given command in Identity, but return it in IO, just as -- a convenient way to have a uniform return type with 'run' (provided it is -- run in IO). run_id_io :: RunCmd Identity.Identity IO Status run_id_io :: RunCmd Identity IO Status run_id_io State ui_state State cmd_state CmdT Identity Status cmd = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Identity a -> a Identity.runIdentity (forall (m :: * -> *) a. Monad m => a -> RunCmd m m a run Status Continue State ui_state State cmd_state CmdT Identity Status cmd) run_io :: RunCmd IO IO Status run_io :: RunCmd IO IO Status run_io = forall (m :: * -> *) a. Monad m => a -> RunCmd m m a run Status Continue -- | Promote a CmdId to a generic cmd, which can also run as a CmdT IO. -- TODO: shouldn't it be possible to do this for free? lift_id :: M m => CmdId a -> m a lift_id :: forall (m :: * -> *) a. M m => CmdId a -> m a lift_id CmdId a cmd = do (State cmd_state, [Thru] thru, [Msg] logs, Either Error (Maybe a, State, UiDamage) result) <- forall a. State -> State -> CmdT Identity a -> Result (Maybe a) run_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => m State Ui.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (m :: * -> *). M m => m State get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Applicative f => a -> f a pure CmdId a cmd forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). LogMonad m => Msg -> m () Log.write [Msg] logs case Either Error (Maybe a, State, UiDamage) result of Left Error err -> forall (m :: * -> *) a. M m => Error -> m a Ui.throw_error Error err Right (Maybe a val, State ui_state, UiDamage damage) -> case Maybe a val of Maybe a Nothing -> forall (m :: * -> *) a. M m => m a abort Just a val -> do forall (m :: * -> *). M m => State -> m () put State cmd_state forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). M m => Thru -> m () write_thru [Thru] thru forall (m :: * -> *). M m => UiDamage -> m () Ui.damage UiDamage damage forall (m :: * -> *). M m => State -> m () Ui.unsafe_put State ui_state forall (m :: * -> *) a. Monad m => a -> m a return a val -- | Run a set of Cmds as a single Cmd. The first one to return non-Continue -- will return. Cmds can use this to dispatch to other Cmds. sequence_cmds :: M m => [a -> m Status] -> a -> m Status sequence_cmds :: forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status sequence_cmds [] a _ = forall (m :: * -> *) a. Monad m => a -> m a return Status Continue sequence_cmds (a -> m Status cmd:[a -> m Status] cmds) a msg = do Maybe Status status <- forall (m :: * -> *) a. M m => m a -> m (Maybe a) catch_abort (a -> m Status cmd a msg) case Maybe Status status of Maybe Status Nothing -> forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status sequence_cmds [a -> m Status] cmds a msg Just Status Continue -> forall (m :: * -> *) a. M m => [a -> m Status] -> a -> m Status sequence_cmds [a -> m Status] cmds a msg Just Status status -> forall (m :: * -> *) a. Monad m => a -> m a return Status status -- * CmdT and operations type CmdStack m = Ui.StateT (MonadState.StateT State (Logger.LoggerT Thru (Log.LogT m))) newtype CmdT m a = CmdT (CmdStack m a) deriving (forall a b. a -> CmdT m b -> CmdT m a forall a b. (a -> b) -> CmdT m a -> CmdT m b forall (m :: * -> *) a b. Functor m => a -> CmdT m b -> CmdT m a forall (m :: * -> *) a b. Functor m => (a -> b) -> CmdT m a -> CmdT m b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: forall a b. a -> CmdT m b -> CmdT m a $c<$ :: forall (m :: * -> *) a b. Functor m => a -> CmdT m b -> CmdT m a fmap :: forall a b. (a -> b) -> CmdT m a -> CmdT m b $cfmap :: forall (m :: * -> *) a b. Functor m => (a -> b) -> CmdT m a -> CmdT m b Functor, forall a. a -> CmdT m a forall a b. CmdT m a -> CmdT m b -> CmdT m b forall a b. CmdT m a -> (a -> CmdT m b) -> CmdT m b forall {m :: * -> *}. Monad m => Applicative (CmdT m) forall (m :: * -> *) a. Monad m => a -> CmdT m a forall (m :: * -> *) a b. Monad m => CmdT m a -> CmdT m b -> CmdT m b forall (m :: * -> *) a b. Monad m => CmdT m a -> (a -> CmdT m b) -> CmdT m b forall (m :: * -> *). Applicative m -> (forall a b. m a -> (a -> m b) -> m b) -> (forall a b. m a -> m b -> m b) -> (forall a. a -> m a) -> Monad m return :: forall a. a -> CmdT m a $creturn :: forall (m :: * -> *) a. Monad m => a -> CmdT m a >> :: forall a b. CmdT m a -> CmdT m b -> CmdT m b $c>> :: forall (m :: * -> *) a b. Monad m => CmdT m a -> CmdT m b -> CmdT m b >>= :: forall a b. CmdT m a -> (a -> CmdT m b) -> CmdT m b $c>>= :: forall (m :: * -> *) a b. Monad m => CmdT m a -> (a -> CmdT m b) -> CmdT m b Monad, forall a. IO a -> CmdT m a forall (m :: * -> *). Monad m -> (forall a. IO a -> m a) -> MonadIO m forall {m :: * -> *}. MonadIO m => Monad (CmdT m) forall (m :: * -> *) a. MonadIO m => IO a -> CmdT m a liftIO :: forall a. IO a -> CmdT m a $cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> CmdT m a MonadIO, Except.MonadError Ui.Error, forall a. a -> CmdT m a forall a b. CmdT m a -> CmdT m b -> CmdT m a forall a b. CmdT m a -> CmdT m b -> CmdT m b forall a b. CmdT m (a -> b) -> CmdT m a -> CmdT m b forall a b c. (a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c forall {m :: * -> *}. Monad m => Functor (CmdT m) forall (m :: * -> *) a. Monad m => a -> CmdT m a forall (m :: * -> *) a b. Monad m => CmdT m a -> CmdT m b -> CmdT m a forall (m :: * -> *) a b. Monad m => CmdT m a -> CmdT m b -> CmdT m b forall (m :: * -> *) a b. Monad m => CmdT m (a -> b) -> CmdT m a -> CmdT m b forall (m :: * -> *) a b c. Monad m => (a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c forall (f :: * -> *). Functor f -> (forall a. a -> f a) -> (forall a b. f (a -> b) -> f a -> f b) -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c) -> (forall a b. f a -> f b -> f b) -> (forall a b. f a -> f b -> f a) -> Applicative f <* :: forall a b. CmdT m a -> CmdT m b -> CmdT m a $c<* :: forall (m :: * -> *) a b. Monad m => CmdT m a -> CmdT m b -> CmdT m a *> :: forall a b. CmdT m a -> CmdT m b -> CmdT m b $c*> :: forall (m :: * -> *) a b. Monad m => CmdT m a -> CmdT m b -> CmdT m b liftA2 :: forall a b c. (a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c $cliftA2 :: forall (m :: * -> *) a b c. Monad m => (a -> b -> c) -> CmdT m a -> CmdT m b -> CmdT m c <*> :: forall a b. CmdT m (a -> b) -> CmdT m a -> CmdT m b $c<*> :: forall (m :: * -> *) a b. Monad m => CmdT m (a -> b) -> CmdT m a -> CmdT m b pure :: forall a. a -> CmdT m a $cpure :: forall (m :: * -> *) a. Monad m => a -> CmdT m a Applicative) class (Log.LogMonad m, Ui.M m) => M m where -- Not in MonadState for the same reasons as 'Ui.Ui.M'. get :: m State put :: State -> m () -- | Log a note to send out. This is the midi or im thru mechanism. write_thru :: Thru -> m () -- | An abort is an exception to get out of CmdT, but it's considered the -- same as returning Continue. It's so a command can back out if e.g. it's -- selected by the 'Keymap' but has an additional prerequisite such as -- having an active block. abort :: m a catch_abort :: m a -> m (Maybe a) instance Monad m => M (CmdT m) where get :: CmdT m State get = (forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift) forall s (m :: * -> *). MonadState s m => m s MonadState.get put :: State -> CmdT m () put State st = (forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift) (forall s (m :: * -> *). MonadState s m => s -> m () MonadState.put State st) write_thru :: Thru -> CmdT m () write_thru Thru msg = (forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift) (forall w (m :: * -> *). MonadLogger w m => w -> m () Logger.log Thru msg) abort :: forall a. CmdT m a abort = forall e (m :: * -> *) a. MonadError e m => e -> m a Except.throwError Error Ui.Abort catch_abort :: forall a. CmdT m a -> CmdT m (Maybe a) catch_abort CmdT m a m = forall e (m :: * -> *) a. MonadError e m => m a -> (e -> m a) -> m a Except.catchError (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. a -> Maybe a Just CmdT m a m) forall {m :: * -> *} {a}. MonadError Error m => Error -> m (Maybe a) catch where catch :: Error -> m (Maybe a) catch Error Ui.Abort = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing catch Error err = forall e (m :: * -> *) a. MonadError e m => e -> m a Except.throwError Error err data Thru = -- | Send MIDI thru. You can give it a timestamp, but it should be 0 for -- thru, which will cause it to go straight to the front of the queue. Use -- 'midi' for normal midi thru. MidiThru !Midi.Interface.Message | ImThru !Thru.Message | OscThru ![OSC.OSC] deriving (Int -> Thru -> ShowS [Thru] -> ShowS Thru -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Thru] -> ShowS $cshowList :: [Thru] -> ShowS show :: Thru -> String $cshow :: Thru -> String showsPrec :: Int -> Thru -> ShowS $cshowsPrec :: Int -> Thru -> ShowS Show) midi_thru :: Midi.WriteDevice -> Midi.Message -> Thru midi_thru :: WriteDevice -> Message -> Thru midi_thru WriteDevice dev Message msg = Message -> Thru MidiThru forall a b. (a -> b) -> a -> b $ WriteMessage -> Message Midi.Interface.Midi forall a b. (a -> b) -> a -> b $ WriteDevice -> RealTime -> Message -> WriteMessage Midi.WriteMessage WriteDevice dev RealTime 0 Message msg midi :: M m => Midi.WriteDevice -> Midi.Message -> m () midi :: forall (m :: * -> *). M m => WriteDevice -> Message -> m () midi WriteDevice dev Message msg = forall (m :: * -> *). M m => Thru -> m () write_thru forall a b. (a -> b) -> a -> b $ WriteDevice -> Message -> Thru midi_thru WriteDevice dev Message msg osc :: M m => [OSC.OSC] -> m () osc :: forall (m :: * -> *). M m => [OSC] -> m () osc = forall (m :: * -> *). M m => Thru -> m () write_thru forall b c a. (b -> c) -> (a -> b) -> a -> c . [OSC] -> Thru OscThru -- | For some reason, newtype deriving doesn't work on MonadTrans. instance Trans.MonadTrans CmdT where lift :: forall (m :: * -> *) a. Monad m => m a -> CmdT m a lift = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift -- whee!! -- | Give CmdT unlifted access to all the logging functions. instance Monad m => Log.LogMonad (CmdT m) where write :: Msg -> CmdT m () write = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). LogMonad m => Msg -> m () Log.write -- | And to the UI state operations. instance Monad m => Ui.M (CmdT m) where get :: CmdT m State get = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall (m :: * -> *). M m => m State Ui.get unsafe_put :: State -> CmdT m () unsafe_put State st = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT (forall (m :: * -> *). M m => State -> m () Ui.unsafe_put State st) damage :: UiDamage -> CmdT m () damage UiDamage upd = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT (forall (m :: * -> *). M m => UiDamage -> m () Ui.damage UiDamage upd) get_damage :: CmdT m UiDamage get_damage = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT forall (m :: * -> *). M m => m UiDamage Ui.get_damage throw_error :: forall a. Error -> CmdT m a throw_error Error msg = forall (m :: * -> *) a. CmdStack m a -> CmdT m a CmdT (forall (m :: * -> *) a. M m => Error -> m a Ui.throw_error Error msg) -- ** exceptions -- | This is the same as Ui.throw, but it feels like things in Cmd may not -- always want to reuse State's exceptions, so they should call this one. throw :: (CallStack.Stack, M m) => Text -> m a throw :: forall (m :: * -> *) a. (Stack, M m) => Text -> m a throw = forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw -- | Run a subcomputation that is allowed to abort. ignore_abort :: M m => m a -> m () ignore_abort :: forall (m :: * -> *) a. M m => m a -> m () ignore_abort m a m = forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. M m => m a -> m (Maybe a) catch_abort m a m -- | Run an IO action, rethrowing any IO exception as a Cmd exception. rethrow_io :: IO a -> CmdT IO a rethrow_io :: forall a. IO a -> CmdT IO a rethrow_io = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either forall (m :: * -> *) a. (Stack, M m) => Text -> m a throw forall (m :: * -> *) a. Monad m => a -> m a return forall (m :: * -> *) b c a. Monad m => (b -> m c) -> (a -> m b) -> a -> m c <=< forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall e a. Exception e => (e -> IO a) -> IO a -> IO a Exception.handle forall a. SomeException -> IO (Either Text a) handle forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a b. b -> Either a b Right <$>) where handle :: Exception.SomeException -> IO (Either Text a) handle :: forall a. SomeException -> IO (Either Text a) handle = forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> Either a b Left forall b c a. (b -> c) -> (a -> b) -> a -> c . (Text "io exception: "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Show a => a -> Text showt -- | Extract a Just value, or 'abort'. Generally used to check for Cmd -- conditions that don't fit into a Keymap. abort_unless :: M m => Maybe a -> m a abort_unless :: forall (m :: * -> *) a. M m => Maybe a -> m a abort_unless = forall b a. b -> (a -> b) -> Maybe a -> b maybe forall (m :: * -> *) a. M m => m a abort forall (m :: * -> *) a. Monad m => a -> m a return -- | Throw an exception with the given msg on Nothing. require :: (CallStack.Stack, M m) => Text -> Maybe a -> m a require :: forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a require Text msg = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. (Stack, M m) => Text -> m a throw Text msg) forall (m :: * -> *) a. Monad m => a -> m a return require_right :: (CallStack.Stack, M m) => (err -> Text) -> Either err a -> m a require_right :: forall (m :: * -> *) err a. (Stack, M m) => (err -> Text) -> Either err a -> m a require_right err -> Text fmt_err = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall (m :: * -> *) a. (Stack, M m) => Text -> m a throw forall b c a. (b -> c) -> (a -> b) -> a -> c . err -> Text fmt_err) forall (m :: * -> *) a. Monad m => a -> m a return -- * State {- | App global state. Unlike 'Ui.State', this is not saved to disk. This is normally modified inside a 'CmdT', which is also a 'State.StateT', so it can also use the UI state functions. If an exception is thrown, both this state and the UI state will be rolled back. This is kind of an unorganized wodge. The problem is that since state is all centralized in one place, every special snowflake Cmd that needs its own bit of state winds up getting its own little knob in here. On one hand, it's non-modular. On the other hand, it lets me keep an eye on it. So far, most Cmds are pretty fundamental, so they more or less deserve their spots here. If it gets out of control, though, I'll have to either come up with a clever way of storing typed data where they can't collide, say by having a Cmd return a new Cmd and keeping the state trapped inside, or a less clever but simpler and easier way like @Map Name Dynamic@. -} data State = State { State -> Config state_config :: !Config -- | If set, the current 'Ui.State' was loaded from this file. -- This is so save can keep saving to the same file. , State -> Maybe (Writable, SaveFile) state_save_file :: !(Maybe (Writable, SaveFile)) , State -> Saved state_saved :: !Saved , State -> Maybe KyCache state_ky_cache :: !(Maybe KyCache) -- | Omit the usual derive delay for these blocks, and trigger a derive. -- This is set by integration, which modifies a block in response to -- another block being derived. Blocks set to derive immediately are also -- considered to have block damage, if they didn't already. This is -- cleared after every cmd. , State -> Set BlockId state_derive_immediately :: !(Set BlockId) -- | History. , State -> History state_history :: !History , State -> HistoryConfig state_history_config :: !HistoryConfig , State -> HistoryCollect state_history_collect :: !HistoryCollect , State -> SelectionHistory state_selection_history :: !SelectionHistory -- | Map of keys held down. Maintained by cmd_record_keys and accessed -- with 'keys_down'. -- The key is the modifier stripped of extraneous info, like mousedown -- position. The value has complete info. , State -> Map Modifier Modifier state_keys_down :: !(Map Modifier Modifier) -- | The block and track that have focus. Commands that address -- a particular block or track will address these. , State -> Maybe ViewId state_focused_view :: !(Maybe ViewId) -- | This contains a Rect for each screen. The first one is the default -- one, if a default is needed, though normally views should show up next -- to other views. , State -> [Rect] state_screens :: ![Rect.Rect] -- | Just indicates that the keycaps window is open. The window is global, -- stored in "Ui.PtrMap", so I don't need to store it here. , State -> Maybe KeycapsState state_keycaps :: !(Maybe KeycapsState) , State -> Maybe KeycapsUpdate state_keycaps_update :: !(Maybe KeycapsUpdate) -- | This is similar to 'Ui.Block.view_status', except that it's global -- instead of per-view. So changes are logged with a special prefix so -- logview can catch them. Really I only need this map to suppress log -- spam. , State -> Map Text Text state_global_status :: !(Map Text Text) , State -> PlayState state_play :: !PlayState , State -> Hooks state_hooks :: !Hooks -- External device tracking. -- | MIDI state of WriteDevices. , State -> WriteDeviceState state_wdev_state :: !WriteDeviceState -- | MIDI state of ReadDevices, including configuration like pitch bend -- range. , State -> ReadDeviceState state_rdev_state :: !InputNote.ReadDeviceState , State -> EditState state_edit :: !EditState -- | The status return for this Cmd. This is used only by the REPL, since -- non-REPL cmds simply return Status as their return value. REPL cmds -- can't do that because they commonly use the return value to return -- an interesting String back to the REPL. , State -> Status state_repl_status :: !Status -- | Enable various debug printing to stdout. , State -> Bool state_debug :: !Bool } deriving (Int -> State -> ShowS [State] -> ShowS State -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [State] -> ShowS $cshowList :: [State] -> ShowS show :: State -> String $cshow :: State -> String showsPrec :: Int -> State -> ShowS $cshowsPrec :: Int -> State -> ShowS Show) data SaveFile = SaveState !Path.Canonical | SaveRepo !Path.Canonical deriving (Int -> SaveFile -> ShowS [SaveFile] -> ShowS SaveFile -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SaveFile] -> ShowS $cshowList :: [SaveFile] -> ShowS show :: SaveFile -> String $cshow :: SaveFile -> String showsPrec :: Int -> SaveFile -> ShowS $cshowsPrec :: Int -> SaveFile -> ShowS Show, SaveFile -> SaveFile -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: SaveFile -> SaveFile -> Bool $c/= :: SaveFile -> SaveFile -> Bool == :: SaveFile -> SaveFile -> Bool $c== :: SaveFile -> SaveFile -> Bool Eq) data Writable = ReadWrite | ReadOnly deriving (Int -> Writable -> ShowS [Writable] -> ShowS Writable -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Writable] -> ShowS $cshowList :: [Writable] -> ShowS show :: Writable -> String $cshow :: Writable -> String showsPrec :: Int -> Writable -> ShowS $cshowsPrec :: Int -> Writable -> ShowS Show, Writable -> Writable -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Writable -> Writable -> Bool $c/= :: Writable -> Writable -> Bool == :: Writable -> Writable -> Bool $c== :: Writable -> Writable -> Bool Eq) -- | This tracks how much the score has been saved to disk. data Saved = Saved { Saved -> SavedState _saved_state :: !SavedState , Saved -> Bool _editor_open :: !Bool } deriving (Saved -> Saved -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Saved -> Saved -> Bool $c/= :: Saved -> Saved -> Bool == :: Saved -> Saved -> Bool $c== :: Saved -> Saved -> Bool Eq, Int -> Saved -> ShowS [Saved] -> ShowS Saved -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Saved] -> ShowS $cshowList :: [Saved] -> ShowS show :: Saved -> String $cshow :: Saved -> String showsPrec :: Int -> Saved -> ShowS $cshowsPrec :: Int -> Saved -> ShowS Show) -- True if state is synced to disk, either because it was just saved and -- not significantly changed, or because it was just loaded. data SavedState = -- | Just loaded from a file. This is almost like SavedChanges, except -- that it's required so 'Cmd.Internal.sync_status' can tell the difference -- between the state changing because it was just loaded (set to -- SavedChanges) and changing due to an edit (set to UnsavedChanges). JustLoaded | UnsavedChanges | SavedChanges deriving (SavedState -> SavedState -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: SavedState -> SavedState -> Bool $c/= :: SavedState -> SavedState -> Bool == :: SavedState -> SavedState -> Bool $c== :: SavedState -> SavedState -> Bool Eq, Int -> SavedState -> ShowS [SavedState] -> ShowS SavedState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SavedState] -> ShowS $cshowList :: [SavedState] -> ShowS show :: SavedState -> String $cshow :: SavedState -> String showsPrec :: Int -> SavedState -> ShowS $cshowsPrec :: Int -> SavedState -> ShowS Show) data KeycapsUpdate = KeycapsUpdate KeycapsState (Maybe ((Int, Int), KeycapsT.Layout)) KeycapsT.RawBindings | KeycapsClose deriving (Int -> KeycapsUpdate -> ShowS [KeycapsUpdate] -> ShowS KeycapsUpdate -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [KeycapsUpdate] -> ShowS $cshowList :: [KeycapsUpdate] -> ShowS show :: KeycapsUpdate -> String $cshow :: KeycapsUpdate -> String showsPrec :: Int -> KeycapsUpdate -> ShowS $cshowsPrec :: Int -> KeycapsUpdate -> ShowS Show) -- | The set of things that can affect a keycaps window. So when this changes, -- the window has to be updated. I assume the KeycapsT.Layout is constant, so -- it's not in here, which allows me to cache global keymaps in CAFs. data KeycapsState = KeycapsState { KeycapsState -> Set Modifier kc_mods :: Set Modifier , KeycapsState -> Int kc_octave :: Pitch.Octave , KeycapsState -> Bool kc_is_kbd_entry :: Bool , KeycapsState -> Maybe Type kc_track_type :: Maybe ParseTitle.Type , KeycapsState -> Maybe Instrument kc_instrument :: Maybe ScoreT.Instrument , KeycapsState -> Maybe ScaleId kc_scale_id :: Maybe Pitch.ScaleId } deriving (Int -> KeycapsState -> ShowS [KeycapsState] -> ShowS KeycapsState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [KeycapsState] -> ShowS $cshowList :: [KeycapsState] -> ShowS show :: KeycapsState -> String $cshow :: KeycapsState -> String showsPrec :: Int -> KeycapsState -> ShowS $cshowsPrec :: Int -> KeycapsState -> ShowS Show, KeycapsState -> KeycapsState -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: KeycapsState -> KeycapsState -> Bool $c/= :: KeycapsState -> KeycapsState -> Bool == :: KeycapsState -> KeycapsState -> Bool $c== :: KeycapsState -> KeycapsState -> Bool Eq) -- | Absolute directory of the save file. state_save_dir :: State -> Maybe FilePath state_save_dir :: State -> Maybe String state_save_dir State state = case State -> Maybe (Writable, SaveFile) state_save_file State state of Maybe (Writable, SaveFile) Nothing -> forall a. Maybe a Nothing Just (Writable _, SaveState Canonical fn) -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ ShowS FilePath.takeDirectory forall a b. (a -> b) -> a -> b $ Canonical -> String Path.to_path Canonical fn Just (Writable _, SaveRepo Canonical repo) -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ ShowS FilePath.takeDirectory forall a b. (a -> b) -> a -> b $ Canonical -> String Path.to_path Canonical repo -- | Unique name for this score, for the global im cache. score_path :: State -> FilePath score_path :: State -> String score_path State state = case State -> Maybe (Writable, SaveFile) state_save_file State state of -- #untitled so it's clear where it came from and unlikely to conflict with -- a real filename. Maybe (Writable, SaveFile) Nothing -> String "#untitled" Just (Writable _, SaveState Canonical fn) -> Canonical -> String strip Canonical fn Just (Writable _, SaveRepo Canonical repo) -> Canonical -> String strip Canonical repo where strip :: Canonical -> String strip = Canonical -> Canonical -> String Path.drop_prefix (Config -> Canonical config_save_dir (State -> Config state_config State state)) -- | A loaded and parsed ky file, or an error string. This also has the files -- loaded and their timestamps, to detect when one has changed. data KyCache = KyCache !(Either Text (Derive.Builtins, Derive.InstrumentAliases)) !Fingerprint -- | This disables the cache mechanism. Tests use this to avoid having -- to set SaveFile. | PermanentKy !(Derive.Builtins, Derive.InstrumentAliases) deriving (Int -> KyCache -> ShowS [KyCache] -> ShowS KyCache -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [KyCache] -> ShowS $cshowList :: [KyCache] -> ShowS show :: KyCache -> String $cshow :: KyCache -> String showsPrec :: Int -> KyCache -> ShowS $cshowsPrec :: Int -> KyCache -> ShowS Show) -- | Keep track of loaded files and a fingerprint for their contents. This is -- used to detect when they should be reloaded. data Fingerprint = Fingerprint ![FilePath] !Int deriving (Fingerprint -> Fingerprint -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Fingerprint -> Fingerprint -> Bool $c/= :: Fingerprint -> Fingerprint -> Bool == :: Fingerprint -> Fingerprint -> Bool $c== :: Fingerprint -> Fingerprint -> Bool Eq, Int -> Fingerprint -> ShowS [Fingerprint] -> ShowS Fingerprint -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Fingerprint] -> ShowS $cshowList :: [Fingerprint] -> ShowS show :: Fingerprint -> String $cshow :: Fingerprint -> String showsPrec :: Int -> Fingerprint -> ShowS $cshowsPrec :: Int -> Fingerprint -> ShowS Show) instance Semigroup Fingerprint where Fingerprint [String] fnames1 Int fprint1 <> :: Fingerprint -> Fingerprint -> Fingerprint <> Fingerprint [String] fnames2 Int fprint2 = [String] -> Int -> Fingerprint Fingerprint ([String] fnames1forall a. Semigroup a => a -> a -> a <>[String] fnames2) (forall a. Hashable a => Int -> a -> Int Hashable.hashWithSalt Int fprint1 Int fprint2) instance Monoid Fingerprint where mempty :: Fingerprint mempty = [String] -> Int -> Fingerprint Fingerprint [] Int 0 mappend :: Fingerprint -> Fingerprint -> Fingerprint mappend = forall a. Semigroup a => a -> a -> a (<>) instance Pretty Fingerprint where pretty :: Fingerprint -> Text pretty (Fingerprint [String] files Int word) = forall a. Pretty a => a -> Text pretty [String] files forall a. Semigroup a => a -> a -> a <> Text ":" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Int word fingerprint :: [Ky.Loaded] -> Fingerprint fingerprint :: [Loaded] -> Fingerprint fingerprint [Loaded] imports = -- The code in 'Ui.ky' gets "" for its filename. [String] -> Int -> Fingerprint Fingerprint (forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t a -> Bool null) [String] fnames) (forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall a. Hashable a => Int -> a -> Int Hashable.hashWithSalt Int 0 [Text] contents) where ([String] fnames, [Text] contents) = forall a b. [(a, b)] -> ([a], [b]) unzip [(String fname, Text content) | Ky.Loaded String fname Text content <- [Loaded] imports] initial_state :: Config -> State initial_state :: Config -> State initial_state Config config = State { state_config :: Config state_config = Config config , state_save_file :: Maybe (Writable, SaveFile) state_save_file = forall a. Maybe a Nothing , state_saved :: Saved state_saved = SavedState -> Bool -> Saved Saved SavedState JustLoaded Bool False , state_ky_cache :: Maybe KyCache state_ky_cache = forall a. Maybe a Nothing , state_derive_immediately :: Set BlockId state_derive_immediately = forall a. Set a Set.empty -- This is a dummy entry needed to bootstrap a Cmd.State. Normally -- 'hist_present' should always have the current state, but the initial -- setup cmd needs a State too. , state_history :: History state_history = HistoryEntry -> History initial_history (State -> HistoryEntry empty_history_entry State Ui.empty) , state_history_config :: HistoryConfig state_history_config = HistoryConfig empty_history_config , state_history_collect :: HistoryCollect state_history_collect = HistoryCollect empty_history_collect , state_selection_history :: SelectionHistory state_selection_history = SelectionHistory empty_selection_history , state_keys_down :: Map Modifier Modifier state_keys_down = forall k a. Map k a Map.empty , state_focused_view :: Maybe ViewId state_focused_view = forall a. Maybe a Nothing , state_screens :: [Rect] state_screens = [] , state_keycaps :: Maybe KeycapsState state_keycaps = forall a. Maybe a Nothing , state_keycaps_update :: Maybe KeycapsUpdate state_keycaps_update = forall a. Maybe a Nothing , state_global_status :: Map Text Text state_global_status = forall k a. Map k a Map.empty , state_play :: PlayState state_play = PlayState initial_play_state , state_hooks :: Hooks state_hooks = forall a. Monoid a => a mempty , state_wdev_state :: WriteDeviceState state_wdev_state = WriteDeviceState empty_wdev_state , state_rdev_state :: ReadDeviceState state_rdev_state = ReadDeviceState InputNote.empty_rdev_state , state_edit :: EditState state_edit = EditState initial_edit_state , state_repl_status :: Status state_repl_status = Status Continue , state_debug :: Bool state_debug = Bool False } -- | Reset the parts of the State which are specific to a \"session\". This -- should be called whenever an entirely new state is loaded. reinit_state :: HistoryEntry -> State -> State reinit_state :: HistoryEntry -> State -> State reinit_state HistoryEntry present State cstate = State cstate { state_history :: History state_history = HistoryEntry -> History initial_history HistoryEntry present -- Performance threads should have been killed by the caller. , state_play :: PlayState state_play = PlayState initial_play_state { state_play_step :: TimeStep state_play_step = PlayState -> TimeStep state_play_step (State -> PlayState state_play State cstate) } -- This is essential, otherwise lots of cmds break on the bad reference. , state_focused_view :: Maybe ViewId state_focused_view = forall a. Maybe a Nothing , state_edit :: EditState state_edit = EditState initial_edit_state { state_time_step :: TimeStep state_time_step = EditState -> TimeStep state_time_step (State -> EditState state_edit State cstate) } } -- ** Config -- | Config type variables that change never or rarely. These mostly come from -- the "App.StaticConfig". data Config = Config { -- | App root, initialized from 'Config.get_app_dir'. Config -> AppDir config_app_dir :: !Path.AppDir , Config -> Canonical config_save_dir :: !Path.Canonical , Config -> Interface config_midi_interface :: !Midi.Interface.Interface -- | Search path for local definition files, from 'Config.definition_path'. , Config -> [String] config_ky_paths :: ![FilePath] -- | Reroute MIDI inputs and outputs. These come from -- 'App.StaticConfig.rdev_map' and 'App.StaticConfig.wdev_map' and probably -- shouldn't be changed at runtime. , Config -> Map ReadDevice ReadDevice config_rdev_map :: !(Map Midi.ReadDevice Midi.ReadDevice) -- | WriteDevices can be score-specific, though, so another map is kept in -- 'Ui.State', which may override the one here. , Config -> Map WriteDevice WriteDevice config_wdev_map :: !(Map Midi.WriteDevice Midi.WriteDevice) , Config -> InstrumentDb config_instrument_db :: !InstrumentDb -- | Library of calls for the deriver. , Config -> Builtins config_builtins :: !Derive.Builtins , Config -> Map Highlight Color config_highlight_colors :: !(Map Color.Highlight Color.Color) , Config -> Config config_im :: !Shared.Config.Config -- | If True, play im audio directly instead of via the play_cache VST. -- This means you don't need a DAW, but if you have MIDI instruments -- they probably won't be very in sync. , Config -> Bool config_im_play_direct :: Bool , Config -> User config_git_user :: !SaveGitT.User } deriving (Int -> Config -> ShowS [Config] -> ShowS Config -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Config] -> ShowS $cshowList :: [Config] -> ShowS show :: Config -> String $cshow :: Config -> String showsPrec :: Int -> Config -> ShowS $cshowsPrec :: Int -> Config -> ShowS Show) -- | Get a midi writer that takes the 'config_wdev_map' into account. state_midi_writer :: State -> Midi.Interface.Message -> IO () state_midi_writer :: State -> Message -> IO () state_midi_writer State state Message imsg = do let out :: Message out = case Message imsg of Midi.Interface.Midi WriteMessage wmsg -> WriteMessage -> Message Midi.Interface.Midi forall a b. (a -> b) -> a -> b $ WriteMessage -> WriteMessage map_wdev WriteMessage wmsg Message _ -> Message imsg Maybe Text mb_err <- forall write_message. RawInterface write_message -> write_message -> IO (Maybe Text) Midi.Interface.write_message (Config -> Interface config_midi_interface (State -> Config state_config State state)) Message out forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust Maybe Text mb_err forall a b. (a -> b) -> a -> b $ \Text err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.warn forall a b. (a -> b) -> a -> b $ Text "error writing " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Message out forall a. Semigroup a => a -> a -> a <> Text ": " forall a. Semigroup a => a -> a -> a <> Text err where map_wdev :: WriteMessage -> WriteMessage map_wdev (Midi.WriteMessage WriteDevice wdev RealTime time Message msg) = WriteDevice -> RealTime -> Message -> WriteMessage Midi.WriteMessage (WriteDevice -> WriteDevice lookup_wdev WriteDevice wdev) RealTime time Message msg lookup_wdev :: WriteDevice -> WriteDevice lookup_wdev WriteDevice wdev = forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault WriteDevice wdev WriteDevice wdev (Config -> Map WriteDevice WriteDevice config_wdev_map (State -> Config state_config State state)) -- | Convert a relative path to place it in the app dir. to_absolute :: State -> Path.Relative -> FilePath to_absolute :: State -> Relative -> String to_absolute State state = AppDir -> Relative -> String Path.to_absolute (Config -> AppDir config_app_dir (State -> Config state_config State state)) -- | This was previously in 'Config', and configured via StaticConfig. But it -- turns out I don't really use StaticConfig. It has a name here just so -- I don't get references to 'Scale.All.lookup_scale' everywhere. lookup_scale :: Derive.LookupScale lookup_scale :: LookupScale lookup_scale = LookupScale Scale.All.lookup_scale -- ** PlayState -- | State concerning derivation, performance, and playing the performance. data PlayState = PlayState { -- | Transport control channel for the player, if one is running. -- This is a list even though I only expect one to run at a time. The -- reason is that if starting a new one stops the old one, there will -- be a small window where the old one has not exited yet. It's probably -- better to wait for the previous one to exit, but I've also had bugs -- where play gets stuck on, that makes me think with the concurrency I'm -- going to wind up with overlapping anyway, so I may as well handle it -- when I see it. PlayState -> [PlayControl] state_play_control :: ![Transport.PlayControl] -- | When changes are made to a block, its performance will be -- recalculated in the background. When the Performance is forced, it will -- replace the existing performance in 'state_performance', if any. This -- means there will be a window in which the performance is out of date, -- but this is better than hanging the responder every time it touches an -- insufficiently lazy part of the performance. , PlayState -> Map BlockId Performance state_performance :: !(Map BlockId Performance) -- | However, some cmds, like play, want the most up to date performance -- even if they have to wait for it. This map will be updated -- immediately. , PlayState -> Map BlockId Performance state_current_performance :: !(Map BlockId Performance) -- | Keep track of current thread working on each performance. If a -- new performance is needed before the old one is complete, it can be -- killed off. , PlayState -> Map BlockId Thread state_performance_threads :: !(Map BlockId Thread) -- | Some play commands start playing from a short distance before the -- cursor. , PlayState -> TimeStep state_play_step :: !TimeStep.TimeStep -- | Contain a StepState if step play is active. Managed in -- "Cmd.StepPlay". , PlayState -> Maybe StepState state_step :: !(Maybe StepState) -- | Globally speed up or slow down performance. It mutiplies the -- timestamps by the reciprocal of this amount, so 2 will play double -- speed, and 0.5 will play half speed. , PlayState -> RealTime state_play_multiplier :: RealTime -- | If set, synchronize with a DAW when the selection is set, and on play -- and stop. , PlayState -> Maybe SyncConfig state_sync :: !(Maybe SyncConfig) -- | Track im progress as updated by 'Msg.ImRenderingRange'. This is -- ultimately displayed on the GUI, but I keep track here so I can take -- minimum and maximum when multiple instruments live on one track. , PlayState -> Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime))) state_im_progress :: !(Map BlockId (Map TrackId (Map ScoreT.Instrument (RealTime, RealTime)))) , PlayState -> Maybe PlayCmd state_previous_play :: !(Maybe PlayCmd) } deriving (Int -> PlayState -> ShowS [PlayState] -> ShowS PlayState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PlayState] -> ShowS $cshowList :: [PlayState] -> ShowS show :: PlayState -> String $cshow :: PlayState -> String showsPrec :: Int -> PlayState -> ShowS $cshowsPrec :: Int -> PlayState -> ShowS Show) -- | Wrapper around CmdId PlayArgs to make it Showable. data PlayCmd = PlayCmd !Text !(CmdId PlayArgs) instance Show PlayCmd where show :: PlayCmd -> String show (PlayCmd Text name CmdId PlayArgs _) = String "PlayCmd " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show Text name -- | Wrap Async to make it showable. I use Async instead of ThreadId because -- I want to make sure they can run their finalizers when the app quits, and -- I can wait on an Async, but not on a ThreadId. At the moment, the -- finalizers are killing im subprocesses. 'kill_thread' uses Async.cancel, -- which synchronously waits for the thread to complete. newtype Thread = Thread (Async.Async ()) instance Show Thread where show :: Thread -> String show = forall a. Show a => a -> String show forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Async a -> ThreadId Async.asyncThreadId forall b c a. (b -> c) -> (a -> b) -> a -> c . Thread -> Async () u where u :: Thread -> Async () u (Thread Async () t) = Async () t kill_thread :: Thread -> IO () kill_thread :: Thread -> IO () kill_thread (Thread Async () async) = forall a. Async a -> IO () Async.cancel Async () async kill_performance_threads :: State -> IO () kill_performance_threads :: State -> IO () kill_performance_threads = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Thread -> IO () kill_thread forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k a. Map k a -> [a] Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c . PlayState -> Map BlockId Thread state_performance_threads forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> PlayState state_play -- | Get currently evaluating root BlockIds. running_threads :: CmdT IO [BlockId] running_threads :: CmdT IO [BlockId] running_threads = do [(BlockId, Thread)] threads <- forall (m :: * -> *) a. M m => (State -> a) -> m a gets forall a b. (a -> b) -> a -> b $ forall k a. Map k a -> [(k, a)] Map.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c . PlayState -> Map BlockId Thread state_performance_threads forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> PlayState state_play [(BlockId, Thread)] alive <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Applicative m => (a -> m Bool) -> [a] -> m [a] filterM (Thread -> IO Bool is_alive forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(BlockId, Thread)] threads forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> a fst [(BlockId, Thread)] alive where is_alive :: Thread -> IO Bool is_alive (Thread Async () async) = forall a. Maybe a -> Bool Maybe.isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Async a -> IO (Maybe (Either SomeException a)) Async.poll Async () async initial_play_state :: PlayState initial_play_state :: PlayState initial_play_state = PlayState { state_play_control :: [PlayControl] state_play_control = [] , state_performance :: Map BlockId Performance state_performance = forall k a. Map k a Map.empty , state_current_performance :: Map BlockId Performance state_current_performance = forall k a. Map k a Map.empty , state_performance_threads :: Map BlockId Thread state_performance_threads = forall k a. Map k a Map.empty , state_play_step :: TimeStep state_play_step = Step -> TimeStep TimeStep.time_step forall a b. (a -> b) -> a -> b $ MarklistMatch -> Rank -> Step TimeStep.RelativeMark MarklistMatch TimeStep.AllMarklists Rank Meter.Section , state_step :: Maybe StepState state_step = forall a. Maybe a Nothing , state_play_multiplier :: RealTime state_play_multiplier = Double -> RealTime RealTime.seconds Double 1 , state_sync :: Maybe SyncConfig state_sync = forall a. Maybe a Nothing , state_im_progress :: Map BlockId (Map TrackId (Map Instrument (RealTime, RealTime))) state_im_progress = forall a. Monoid a => a mempty , state_previous_play :: Maybe PlayCmd state_previous_play = forall a. Maybe a Nothing } -- | Step play is a way of playing back the performance in non-realtime. data StepState = StepState { -- - constant -- | Keep track of the view step play was started in, so I know where to -- display the selection. StepState -> ViewId step_view_id :: !ViewId -- | If step play only applies to a few tracks, list them. If null, -- step play applies to all tracks. , StepState -> [Int] step_tracknums :: [TrackNum] -- - modified -- | MIDI states before the step play position, in descending order. , StepState -> [(ScoreTime, State)] step_before :: ![(ScoreTime, Midi.State.State)] -- | MIDI states after the step play position, in asceding order. , StepState -> [(ScoreTime, State)] step_after :: ![(ScoreTime, Midi.State.State)] } deriving (Int -> StepState -> ShowS [StepState] -> ShowS StepState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [StepState] -> ShowS $cshowList :: [StepState] -> ShowS show :: StepState -> String $cshow :: StepState -> String showsPrec :: Int -> StepState -> ShowS $cshowsPrec :: Int -> StepState -> ShowS Show) -- | Configure synchronization. MMC is used to set the play position and MTC -- is used to start and stop playing. -- -- MMC has start and stop msgs, but they seem useless, since they're sysexes, -- which are not delivered precisely. data SyncConfig = SyncConfig { SyncConfig -> WriteDevice sync_device :: !Midi.WriteDevice -- | Send MMC to this device. , SyncConfig -> Channel sync_device_id :: !Mmc.DeviceId -- | If true, send MTC on the 'sync_device'. If this is set, MMC play and -- stop will be omitted, since the presence of MTC should be enough to get -- the DAW started, provided it's in external sync mode. -- -- DAWs tend to spend a long time synchronizing, presumably because -- hardware devices take time to spin up. That's unnecessary in software, -- so in Cubase you can set \"lock frames\" to 2, and in Reaper you can set -- \"synchronize by seeking ahead\" to 67ms. , SyncConfig -> Bool sync_mtc :: !Bool , SyncConfig -> FrameRate sync_frame_rate :: !Midi.FrameRate } deriving (Int -> SyncConfig -> ShowS [SyncConfig] -> ShowS SyncConfig -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SyncConfig] -> ShowS $cshowList :: [SyncConfig] -> ShowS show :: SyncConfig -> String $cshow :: SyncConfig -> String showsPrec :: Int -> SyncConfig -> ShowS $cshowsPrec :: Int -> SyncConfig -> ShowS Show) instance Pretty SyncConfig where format :: SyncConfig -> Doc format (SyncConfig WriteDevice dev Channel dev_id Bool mtc FrameRate rate) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "SyncConfig" [ (Text "device", forall a. Pretty a => a -> Doc Pretty.format WriteDevice dev) , (Text "device_id", forall a. Pretty a => a -> Doc Pretty.format Channel dev_id) , (Text "mtc", forall a. Pretty a => a -> Doc Pretty.format Bool mtc) , (Text "frame_rate", Text -> Doc Pretty.text (forall a. Show a => a -> Text showt FrameRate rate)) ] -- ** hooks -- | Hooks are Cmds that run after some event. newtype Hooks = Hooks { -- | Run when the selection changes. Hooks -> [[(ViewId, Maybe TrackSelection)] -> CmdId ()] hooks_selection :: [[(ViewId, Maybe TrackSelection)] -> CmdId ()] } -- | Just a 'Sel.Selection' annotated with its BlockId and TrackId. There's -- no deep reason for it, it just saves a bit of work for selection hooks. type TrackSelection = (Sel.Selection, BlockId, Maybe TrackId) instance Show Hooks where show :: Hooks -> String show (Hooks [[(ViewId, Maybe TrackSelection)] -> CmdId ()] sel) = String "((Hooks " forall a. [a] -> [a] -> [a] ++ forall a. Show a => a -> String show (forall (t :: * -> *) a. Foldable t => t a -> Int length [[(ViewId, Maybe TrackSelection)] -> CmdId ()] sel) forall a. [a] -> [a] -> [a] ++ String "))" instance Semigroup Hooks where Hooks [[(ViewId, Maybe TrackSelection)] -> CmdId ()] sel1 <> :: Hooks -> Hooks -> Hooks <> Hooks [[(ViewId, Maybe TrackSelection)] -> CmdId ()] sel2 = [[(ViewId, Maybe TrackSelection)] -> CmdId ()] -> Hooks Hooks ([[(ViewId, Maybe TrackSelection)] -> CmdId ()] sel1 forall a. Semigroup a => a -> a -> a <> [[(ViewId, Maybe TrackSelection)] -> CmdId ()] sel2) instance Monoid Hooks where mempty :: Hooks mempty = [[(ViewId, Maybe TrackSelection)] -> CmdId ()] -> Hooks Hooks [] mappend :: Hooks -> Hooks -> Hooks mappend = forall a. Semigroup a => a -> a -> a (<>) -- ** EditState -- | Editing state, modified in the course of editing. data EditState = EditState { -- | Edit mode enables various commands that write to tracks. EditState -> EditMode state_edit_mode :: !EditMode -- | True if the floating input edit is open. , EditState -> Bool state_floating_input :: !Bool -- | Whether or not to advance the insertion point after a note is -- entered. , EditState -> Bool state_advance :: Bool -- | Chord mode means the note is considered entered when all NoteOffs -- have been received. While a note is held down, the insertion point will -- move to the next note track with the same instrument so you can -- enter chords. -- -- When chord mode is off, the note is considered entered as soon as -- its NoteOn is received. , EditState -> Bool state_chord :: Bool -- | Try to find or create a 'Controls.dynamic' track for to record -- 'InputNote.Input' velocity, similar to how a pitch track is edited and -- created. , EditState -> Bool state_record_velocity :: Bool -- | Use the alphanumeric keys to enter notes in addition to midi input. , EditState -> Bool state_kbd_entry :: !Bool -- | Default time step for cursor movement. , EditState -> TimeStep state_time_step :: !TimeStep.TimeStep -- | Used for note duration. It's separate from 'state_time_step' to -- allow for tracker-style note entry where newly entered notes extend to -- the next note or the end of the block. , EditState -> TimeStep state_note_duration :: !TimeStep.TimeStep -- | If this is Negative, create notes with negative durations. , EditState -> Orientation state_note_orientation :: !Types.Orientation -- | New notes get this text by default. This way, you can enter a series -- of notes with the same attributes, or whatever. , EditState -> Text state_note_text :: !Text -- | Transpose note entry on the keyboard by this many octaves. It's by -- octave instead of scale degree since scales may have different numbers -- of notes per octave. , EditState -> Int state_kbd_entry_octave :: !Pitch.Octave , EditState -> RecordedActions state_recorded_actions :: !RecordedActions , EditState -> Map Instrument Attributes state_instrument_attributes :: !(Map ScoreT.Instrument Attrs.Attributes) -- | See 'set_edit_box'. , EditState -> (Box, Box) state_edit_box :: !(Block.Box, Block.Box) } deriving (EditState -> EditState -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: EditState -> EditState -> Bool $c/= :: EditState -> EditState -> Bool == :: EditState -> EditState -> Bool $c== :: EditState -> EditState -> Bool Eq, Int -> EditState -> ShowS [EditState] -> ShowS EditState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [EditState] -> ShowS $cshowList :: [EditState] -> ShowS show :: EditState -> String $cshow :: EditState -> String showsPrec :: Int -> EditState -> ShowS $cshowsPrec :: Int -> EditState -> ShowS Show) initial_edit_state :: EditState initial_edit_state :: EditState initial_edit_state = EditState { state_edit_mode :: EditMode state_edit_mode = EditMode NoEdit , state_floating_input :: Bool state_floating_input = Bool False , state_kbd_entry :: Bool state_kbd_entry = Bool False , state_advance :: Bool state_advance = Bool True , state_chord :: Bool state_chord = Bool False , state_record_velocity :: Bool state_record_velocity = Bool False , state_time_step :: TimeStep state_time_step = PlayState -> TimeStep state_play_step PlayState initial_play_state , state_note_duration :: TimeStep state_note_duration = TimeStep TimeStep.event_edge , state_note_orientation :: Orientation state_note_orientation = Orientation Types.Positive , state_note_text :: Text state_note_text = Text "" -- This should put middle C in the center of the kbd entry keys. , state_kbd_entry_octave :: Int state_kbd_entry_octave = Int 3 , state_recorded_actions :: RecordedActions state_recorded_actions = forall a. Monoid a => a mempty , state_instrument_attributes :: Map Instrument Attributes state_instrument_attributes = forall a. Monoid a => a mempty , state_edit_box :: (Box, Box) state_edit_box = (Box box, Box box) } where box :: Box box = forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Color -> Char -> Box Block.Box (Color, Char) Config.bconfig_box -- | These enable various commands to edit event text. What exactly val -- and method mean are dependent on the track. data EditMode = NoEdit | ValEdit | MethodEdit deriving (EditMode -> EditMode -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: EditMode -> EditMode -> Bool $c/= :: EditMode -> EditMode -> Bool == :: EditMode -> EditMode -> Bool $c== :: EditMode -> EditMode -> Bool Eq, Int -> EditMode -> ShowS [EditMode] -> ShowS EditMode -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [EditMode] -> ShowS $cshowList :: [EditMode] -> ShowS show :: EditMode -> String $cshow :: EditMode -> String showsPrec :: Int -> EditMode -> ShowS $cshowsPrec :: Int -> EditMode -> ShowS Show) instance Pretty EditMode where pretty :: EditMode -> Text pretty = forall a. Show a => a -> Text showt type RecordedActions = Map Char Action -- | Repeat a recorded action. -- -- Select event and duration and hit shift-1 to record InsertEvent. -- Text edits record ReplaceText, PrependText, or AppendText in the last -- action field (bound to '.'), which you can then save. data Action = -- | If a duration is given, the event has that duration, otherwise -- it gets the current time step. InsertEvent !(Maybe TrackTime) !Text | ReplaceText !Text | PrependText !Text | AppendText !Text deriving (Int -> Action -> ShowS [Action] -> ShowS Action -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Action] -> ShowS $cshowList :: [Action] -> ShowS show :: Action -> String $cshow :: Action -> String showsPrec :: Int -> Action -> ShowS $cshowsPrec :: Int -> Action -> ShowS Show, Action -> Action -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Action -> Action -> Bool $c/= :: Action -> Action -> Bool == :: Action -> Action -> Bool $c== :: Action -> Action -> Bool Eq) instance Pretty Action where pretty :: Action -> Text pretty Action act = case Action act of InsertEvent Maybe ScoreTime maybe_dur Text text -> forall a. Pretty a => a -> Text pretty Text text forall a. Semigroup a => a -> a -> a <> Text " (" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Maybe ScoreTime maybe_dur forall a. Semigroup a => a -> a -> a <> Text ")" ReplaceText Text text -> Text "=" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Text text PrependText Text text -> forall a. Pretty a => a -> Text pretty Text text forall a. Semigroup a => a -> a -> a <> Text "+" AppendText Text text -> Text "+" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Text text -- *** midi devices data WriteDeviceState = WriteDeviceState { -- Used by Cmd.MidiThru: -- | NoteId currently playing in each Addr. An Addr may have >1 NoteId. WriteDeviceState -> Map NoteId Addr wdev_note_addr :: !(Map InputNote.NoteId Patch.Addr) -- | The note id is not guaranteed to have any relationship to the key, -- so the MIDI NoteOff needs to know what key the MIDI NoteOn used. , WriteDeviceState -> Map NoteId Key wdev_note_key :: !(Map InputNote.NoteId Midi.Key) -- | Map an addr to a number that increases when it's assigned a note. -- This is used along with 'wdev_serial' to implement addr round-robin. , WriteDeviceState -> Map Addr Int wdev_addr_serial :: !(Map Patch.Addr Serial) -- | Next serial number for 'wdev_addr_serial'. , WriteDeviceState -> Int wdev_serial :: !Serial -- | Last NoteId seen. This is needed to emit controls (rather than just -- mapping them from MIDI input) because otherwise there's no way to know -- to which note they should be assigned. , WriteDeviceState -> Maybe NoteId wdev_last_note_id :: !(Maybe InputNote.NoteId) -- Used by Cmd.PitchTrack: -- | NoteIds being entered into which pitch tracks. When entering a chord, -- a PitchChange uses this to know which pitch track to update. , WriteDeviceState -> Map NoteId (BlockId, Int) wdev_pitch_track :: !(Map InputNote.NoteId (BlockId, TrackNum)) -- Used by no one, yet: (TODO should someone use this?) -- | Remember the current patch of each addr. More than one patch or -- keyswitch can share the same addr, so I need to keep track which one is -- active to minimize switches. , WriteDeviceState -> Map Addr Patch wdev_addr_inst :: !(Map Patch.Addr Midi.Types.Patch) } deriving (WriteDeviceState -> WriteDeviceState -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: WriteDeviceState -> WriteDeviceState -> Bool $c/= :: WriteDeviceState -> WriteDeviceState -> Bool == :: WriteDeviceState -> WriteDeviceState -> Bool $c== :: WriteDeviceState -> WriteDeviceState -> Bool Eq, Int -> WriteDeviceState -> ShowS [WriteDeviceState] -> ShowS WriteDeviceState -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [WriteDeviceState] -> ShowS $cshowList :: [WriteDeviceState] -> ShowS show :: WriteDeviceState -> String $cshow :: WriteDeviceState -> String showsPrec :: Int -> WriteDeviceState -> ShowS $cshowsPrec :: Int -> WriteDeviceState -> ShowS Show) type Serial = Int empty_wdev_state :: WriteDeviceState empty_wdev_state :: WriteDeviceState empty_wdev_state = WriteDeviceState { wdev_note_addr :: Map NoteId Addr wdev_note_addr = forall k a. Map k a Map.empty , wdev_note_key :: Map NoteId Key wdev_note_key = forall k a. Map k a Map.empty , wdev_addr_serial :: Map Addr Int wdev_addr_serial = forall k a. Map k a Map.empty , wdev_serial :: Int wdev_serial = Int 0 , wdev_last_note_id :: Maybe NoteId wdev_last_note_id = forall a. Maybe a Nothing , wdev_pitch_track :: Map NoteId (BlockId, Int) wdev_pitch_track = forall k a. Map k a Map.empty , wdev_addr_inst :: Map Addr Patch wdev_addr_inst = forall k a. Map k a Map.empty } -- *** performance perf_tempo :: Performance -> Transport.TempoFunction perf_tempo :: Performance -> TempoFunction perf_tempo = [TrackWarp] -> TempoFunction TrackWarp.tempo_func forall b c a. (b -> c) -> (a -> b) -> a -> c . Performance -> [TrackWarp] perf_warps perf_inv_tempo :: Performance -> Transport.InverseTempoFunction perf_inv_tempo :: Performance -> InverseTempoFunction perf_inv_tempo = [TrackWarp] -> InverseTempoFunction TrackWarp.inverse_tempo_func forall b c a. (b -> c) -> (a -> b) -> a -> c . Performance -> [TrackWarp] perf_warps perf_closest_warp :: Performance -> Transport.ClosestWarpFunction perf_closest_warp :: Performance -> ClosestWarpFunction perf_closest_warp = [TrackWarp] -> ClosestWarpFunction TrackWarp.closest_warp forall b c a. (b -> c) -> (a -> b) -> a -> c . Performance -> [TrackWarp] perf_warps -- *** instrument -- | The code part of an instrument, i.e. the calls and cmds it brings into -- scope. -- -- This has to be in Cmd.Cmd for circular import reasons. data InstrumentCode = InstrumentCode { InstrumentCode -> InstrumentCalls inst_calls :: !Derive.InstrumentCalls , InstrumentCode -> InstrumentPostproc inst_postproc :: !InstrumentPostproc , InstrumentCode -> [HandlerId] inst_cmds :: ![HandlerId] -- | An optional specialized cmd to write Thru. This is separate from -- 'inst_cmds' so it can be run wherever the instrument needs special thru, -- not just in the instrument's note track. This way custom thru works in -- the pitch track too. , InstrumentCode -> Maybe ThruFunction inst_thru :: !(Maybe ThruFunction) } type ThruFunction = Scale.Scale -> Attrs.Attributes -> InputNote.Input -> CmdId [Thru] -- | Process each event before conversion. This is like a postproc call, -- but it can only map events 1:1 and you don't have to explicitly call it. -- -- This can change the duration, but should not change 'Score.event_start', -- because the events are not resorted afterwards. Also, it's applied during -- conversion, so it only makes sense to modify 'Score.event_duration', -- 'Score.event_controls', 'Score.event_pitch', and 'Score.event_environ'. -- TODO so I could have it return just those? But then it has to return Maybe -- to not modify and needs a record type. type InstrumentPostproc = Score.Event -> (Score.Event, [Log.Msg]) instance Show InstrumentCode where show :: InstrumentCode -> String show InstrumentCode _ = String "((InstrumentCode))" instance Pretty InstrumentCode where format :: InstrumentCode -> Doc format (InstrumentCode InstrumentCalls calls InstrumentPostproc _ [HandlerId] cmds Maybe ThruFunction thru) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "InstrumentCode" [ (Text "calls", forall a. Pretty a => a -> Doc Pretty.format InstrumentCalls calls) , (Text "cmds", forall a. Pretty a => a -> Doc Pretty.format [HandlerId] cmds) , (Text "thru", forall a. Pretty a => a -> Doc Pretty.format Maybe ThruFunction thru) ] make_derive_instrument :: ResolvedInstrument -> Derive.Instrument make_derive_instrument :: ResolvedInstrument -> Instrument make_derive_instrument ResolvedInstrument resolved = Derive.Instrument { inst_calls :: InstrumentCalls inst_calls = InstrumentCode -> InstrumentCalls inst_calls forall a b. (a -> b) -> a -> b $ forall code. Common code -> code Common.common_code forall a b. (a -> b) -> a -> b $ forall code. Inst code -> Common code Inst.inst_common forall a b. (a -> b) -> a -> b $ ResolvedInstrument -> Inst inst_instrument ResolvedInstrument resolved , inst_environ :: Environ inst_environ = Environ -> Environ REnv.convert forall a b. (a -> b) -> a -> b $ Config -> Environ Common.config_environ forall a b. (a -> b) -> a -> b $ ResolvedInstrument -> Config inst_common_config ResolvedInstrument resolved , inst_controls :: ControlValMap inst_controls = Config -> ControlValMap Common.config_controls (ResolvedInstrument -> Config inst_common_config ResolvedInstrument resolved) , inst_attributes :: [Attributes] inst_attributes = forall code. Inst code -> [Attributes] Inst.inst_attributes (ResolvedInstrument -> Inst inst_instrument ResolvedInstrument resolved) , inst_elements :: Set Text inst_elements = case forall code. Inst code -> Backend Inst.inst_backend (ResolvedInstrument -> Inst inst_instrument ResolvedInstrument resolved) of Inst.Im Patch patch -> Patch -> Set Text Im.Patch.patch_elements Patch patch Backend _ -> forall a. Monoid a => a mempty } empty_code :: InstrumentCode empty_code :: InstrumentCode empty_code = InstrumentCode { inst_calls :: InstrumentCalls inst_calls = forall a. Monoid a => a mempty , inst_postproc :: InstrumentPostproc inst_postproc = (,[]) , inst_cmds :: [HandlerId] inst_cmds = [] , inst_thru :: Maybe ThruFunction inst_thru = forall a. Maybe a Nothing } -- | Instantiate 'Inst.Db' with the code type. The only reason the Db has the -- type parameter is so I can define it in its own module without a circular -- import. type InstrumentDb = Inst.Db InstrumentCode -- | Like 'InstrumentDb'. type Inst = Inst.Inst InstrumentCode -- *** history -- | Ghosts of state past, present, and future. data History = History { History -> [HistoryEntry] hist_past :: ![HistoryEntry] -- | The present is actually the immediate past. When you undo, the -- undo itself is actually in the future of the state you want to undo. -- So another way of looking at it is that you undo from the past to -- a point further in the past. But since you always require a \"recent -- past\" to exist, it's more convenient to break it out and call it the -- \"present\". Isn't time travel confusing? , History -> HistoryEntry hist_present :: !HistoryEntry , History -> [HistoryEntry] hist_future :: ![HistoryEntry] , History -> Maybe LastCmd hist_last_cmd :: !(Maybe LastCmd) } deriving (Int -> History -> ShowS [History] -> ShowS History -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [History] -> ShowS $cshowList :: [History] -> ShowS show :: History -> String $cshow :: History -> String showsPrec :: Int -> History -> ShowS $cshowsPrec :: Int -> History -> ShowS Show) initial_history :: HistoryEntry -> History initial_history :: HistoryEntry -> History initial_history HistoryEntry present = [HistoryEntry] -> HistoryEntry -> [HistoryEntry] -> Maybe LastCmd -> History History [] HistoryEntry present [] forall a. Maybe a Nothing -- | Record some information about the last cmd for the benefit of -- 'Cmd.Undo.maintain_history'. data LastCmd = -- | This cmd set the state because it was an undo or redo. Otherwise undo -- and redo themselves would be recorded and multiple undo would be -- impossible! UndoRedo -- | This cmd set the state because of a load. This should reset all the -- history so I can start loading from the new state's history. | Load (Maybe GitT.Commit) [Text] deriving (Int -> LastCmd -> ShowS [LastCmd] -> ShowS LastCmd -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [LastCmd] -> ShowS $cshowList :: [LastCmd] -> ShowS show :: LastCmd -> String $cshow :: LastCmd -> String showsPrec :: Int -> LastCmd -> ShowS $cshowsPrec :: Int -> LastCmd -> ShowS Show) data HistoryConfig = HistoryConfig { -- | Keep this many previous history entries in memory. HistoryConfig -> Int hist_keep :: !Int -- | Checkpoints are saved relative to the state at the next checkpoint. -- So it's important to keep the commit of that checkpoint up to date, -- otherwise the state and the checkpoints will get out of sync. , HistoryConfig -> Maybe Commit hist_last_commit :: !(Maybe GitT.Commit) } deriving (Int -> HistoryConfig -> ShowS [HistoryConfig] -> ShowS HistoryConfig -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [HistoryConfig] -> ShowS $cshowList :: [HistoryConfig] -> ShowS show :: HistoryConfig -> String $cshow :: HistoryConfig -> String showsPrec :: Int -> HistoryConfig -> ShowS $cshowsPrec :: Int -> HistoryConfig -> ShowS Show) empty_history_config :: HistoryConfig empty_history_config :: HistoryConfig empty_history_config = Int -> Maybe Commit -> HistoryConfig HistoryConfig Int Config.default_keep_history forall a. Maybe a Nothing data HistoryCollect = HistoryCollect { -- | This is cleared after each cmd. A cmd can cons its name on, and -- the cmd is recorded with the (optional) set of names it returns. -- Hopefully each cmd has at least one name, since this makes the history -- more readable. There can be more than one name if the history records -- several cmds or if one cmd calls another. HistoryCollect -> [Text] state_cmd_names :: ![Text] -- | Suppress history record until the EditMode changes from the given one. -- This is a bit of a hack so that every keystroke in a raw edit isn't -- recorded separately. , HistoryCollect -> Maybe EditMode state_suppress_edit :: !(Maybe EditMode) -- | The Git.Commit in the SaveHistory should definitely be Nothing. , HistoryCollect -> Maybe SaveHistory state_suppressed :: !(Maybe SaveGitT.SaveHistory) } deriving (Int -> HistoryCollect -> ShowS [HistoryCollect] -> ShowS HistoryCollect -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [HistoryCollect] -> ShowS $cshowList :: [HistoryCollect] -> ShowS show :: HistoryCollect -> String $cshow :: HistoryCollect -> String showsPrec :: Int -> HistoryCollect -> ShowS $cshowsPrec :: Int -> HistoryCollect -> ShowS Show) empty_history_collect :: HistoryCollect empty_history_collect :: HistoryCollect empty_history_collect = HistoryCollect { state_cmd_names :: [Text] state_cmd_names = [] , state_suppress_edit :: Maybe EditMode state_suppress_edit = forall a. Maybe a Nothing , state_suppressed :: Maybe SaveHistory state_suppressed = forall a. Maybe a Nothing } data HistoryEntry = HistoryEntry { HistoryEntry -> State hist_state :: !Ui.State -- | Since track event updates are not caught by diff but recorded by -- Ui.State, I have to save those too, or else an undo or redo will miss -- the event changes. TODO ugly, can I avoid this? -- -- If this HistoryEntry is in the past, these are the updates that took it -- to the future, not the updates emitted by the cmd itself. If the -- HistoryEntry is in the future, the updates take it to the past, which -- are the updated emitted by the cmd. So don't be confused if it looks -- like a HistoryEntry has the wrong updates. , HistoryEntry -> UiDamage hist_damage :: !Update.UiDamage -- | Cmds involved creating this entry. , HistoryEntry -> [Text] hist_names :: ![Text] -- | The Commit where this entry was saved. Nothing if the entry is -- unsaved. , HistoryEntry -> Maybe Commit hist_commit :: !(Maybe GitT.Commit) } deriving (Int -> HistoryEntry -> ShowS [HistoryEntry] -> ShowS HistoryEntry -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [HistoryEntry] -> ShowS $cshowList :: [HistoryEntry] -> ShowS show :: HistoryEntry -> String $cshow :: HistoryEntry -> String showsPrec :: Int -> HistoryEntry -> ShowS $cshowsPrec :: Int -> HistoryEntry -> ShowS Show) empty_history_entry :: Ui.State -> HistoryEntry empty_history_entry :: State -> HistoryEntry empty_history_entry State state = HistoryEntry { hist_state :: State hist_state = State state , hist_damage :: UiDamage hist_damage = forall a. Monoid a => a mempty , hist_names :: [Text] hist_names = [] , hist_commit :: Maybe Commit hist_commit = forall a. Maybe a Nothing } instance Pretty History where format :: History -> Doc format (History [HistoryEntry] past HistoryEntry present [HistoryEntry] future Maybe LastCmd last_cmd) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "History" [ (Text "past", forall a. Pretty a => a -> Doc Pretty.format [HistoryEntry] past) , (Text "present", forall a. Pretty a => a -> Doc Pretty.format HistoryEntry present) , (Text "future", forall a. Pretty a => a -> Doc Pretty.format [HistoryEntry] future) , (Text "last_cmd", Text -> Doc Pretty.text (forall a. Show a => a -> Text showt Maybe LastCmd last_cmd)) ] instance Pretty HistoryEntry where format :: HistoryEntry -> Doc format (HistoryEntry State _state UiDamage damage [Text] commands Maybe Commit commit) = forall a. Pretty a => a -> Doc Pretty.format Maybe Commit commit Doc -> Doc -> Doc Pretty.<+> [Text] -> Doc Pretty.textList [Text] commands Doc -> Doc -> Doc Pretty.<+> forall a. Pretty a => a -> Doc Pretty.format UiDamage damage instance Pretty HistoryConfig where format :: HistoryConfig -> Doc format (HistoryConfig Int keep Maybe Commit last_commit) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "HistoryConfig" [ (Text "keep", forall a. Pretty a => a -> Doc Pretty.format Int keep) , (Text "last_commit", forall a. Pretty a => a -> Doc Pretty.format Maybe Commit last_commit) ] instance Pretty HistoryCollect where format :: HistoryCollect -> Doc format (HistoryCollect [Text] names Maybe EditMode edit Maybe SaveHistory suppressed) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "HistoryCollect" [ (Text "names", forall a. Pretty a => a -> Doc Pretty.format [Text] names) , (Text "suppress_edit", forall a. Pretty a => a -> Doc Pretty.format Maybe EditMode edit) , (Text "suppressed", forall a. Pretty a => a -> Doc Pretty.format Maybe SaveHistory suppressed) ] -- *** SelectionHistory -- | Remember previous selections. This should be updated only by significant -- movements, so clicks and cmd-a, but not hjkl stuff. data SelectionHistory = SelectionHistory { SelectionHistory -> [(ViewId, Selection)] sel_past :: [(ViewId, Sel.Selection)] , SelectionHistory -> [(ViewId, Selection)] sel_future :: [(ViewId, Sel.Selection)] } deriving (SelectionHistory -> SelectionHistory -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: SelectionHistory -> SelectionHistory -> Bool $c/= :: SelectionHistory -> SelectionHistory -> Bool == :: SelectionHistory -> SelectionHistory -> Bool $c== :: SelectionHistory -> SelectionHistory -> Bool Eq, Int -> SelectionHistory -> ShowS [SelectionHistory] -> ShowS SelectionHistory -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SelectionHistory] -> ShowS $cshowList :: [SelectionHistory] -> ShowS show :: SelectionHistory -> String $cshow :: SelectionHistory -> String showsPrec :: Int -> SelectionHistory -> ShowS $cshowsPrec :: Int -> SelectionHistory -> ShowS Show) empty_selection_history :: SelectionHistory empty_selection_history :: SelectionHistory empty_selection_history = [(ViewId, Selection)] -> [(ViewId, Selection)] -> SelectionHistory SelectionHistory [] [] instance Pretty SelectionHistory where format :: SelectionHistory -> Doc format (SelectionHistory [(ViewId, Selection)] past [(ViewId, Selection)] future) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "SelectionHistory" [ (Text "past", forall a. Pretty a => a -> Doc Pretty.format [(ViewId, Selection)] past) , (Text "future", forall a. Pretty a => a -> Doc Pretty.format [(ViewId, Selection)] future) ] -- *** modifier data Modifier = KeyMod Key.Modifier -- | Mouse button, and track it went down at, if any. The block is not -- recorded. You can't drag across blocks so you know any click must -- apply to the focused block. | MouseMod Types.MouseButton (Maybe (TrackNum, UiMsg.Track)) -- | Only chan and key are stored. While it may be useful to map according -- to the device, this code doesn't know which devices are available. -- Block or track level handlers can query the device themselves. | MidiMod Midi.Channel Midi.Key deriving (Modifier -> Modifier -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Modifier -> Modifier -> Bool $c/= :: Modifier -> Modifier -> Bool == :: Modifier -> Modifier -> Bool $c== :: Modifier -> Modifier -> Bool Eq, Eq Modifier Modifier -> Modifier -> Bool Modifier -> Modifier -> Ordering Modifier -> Modifier -> Modifier forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Modifier -> Modifier -> Modifier $cmin :: Modifier -> Modifier -> Modifier max :: Modifier -> Modifier -> Modifier $cmax :: Modifier -> Modifier -> Modifier >= :: Modifier -> Modifier -> Bool $c>= :: Modifier -> Modifier -> Bool > :: Modifier -> Modifier -> Bool $c> :: Modifier -> Modifier -> Bool <= :: Modifier -> Modifier -> Bool $c<= :: Modifier -> Modifier -> Bool < :: Modifier -> Modifier -> Bool $c< :: Modifier -> Modifier -> Bool compare :: Modifier -> Modifier -> Ordering $ccompare :: Modifier -> Modifier -> Ordering Ord, Int -> Modifier -> ShowS [Modifier] -> ShowS Modifier -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Modifier] -> ShowS $cshowList :: [Modifier] -> ShowS show :: Modifier -> String $cshow :: Modifier -> String showsPrec :: Int -> Modifier -> ShowS $cshowsPrec :: Int -> Modifier -> ShowS Show, ReadPrec [Modifier] ReadPrec Modifier Int -> ReadS Modifier ReadS [Modifier] forall a. (Int -> ReadS a) -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a readListPrec :: ReadPrec [Modifier] $creadListPrec :: ReadPrec [Modifier] readPrec :: ReadPrec Modifier $creadPrec :: ReadPrec Modifier readList :: ReadS [Modifier] $creadList :: ReadS [Modifier] readsPrec :: Int -> ReadS Modifier $creadsPrec :: Int -> ReadS Modifier Read) instance Pretty Modifier where pretty :: Modifier -> Text pretty = \case KeyMod Modifier mod -> forall a. Pretty a => a -> Text pretty Modifier mod MouseMod Int button Maybe (Int, Track) mb_track -> Text "MouseMod" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Int button, Maybe (Int, Track) mb_track) MidiMod Channel chan Key key -> Text "MidiMod" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Channel chan, Key key) mouse_mod_btn :: Modifier -> Maybe Types.MouseButton mouse_mod_btn :: Modifier -> Maybe Int mouse_mod_btn (MouseMod Int btn Maybe (Int, Track) _) = forall a. a -> Maybe a Just Int btn mouse_mod_btn Modifier _ = forall a. Maybe a Nothing -- | Take a modifier to its key in the modifier map which has extra info like -- mouse down position stripped. strip_modifier :: Modifier -> Modifier strip_modifier :: Modifier -> Modifier strip_modifier (MouseMod Int btn Maybe (Int, Track) _) = Int -> Maybe (Int, Track) -> Modifier MouseMod Int btn forall a. Maybe a Nothing strip_modifier Modifier mod = Modifier mod -- ** state access gets :: M m => (State -> a) -> m a gets :: forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> a f = do State state <- forall (m :: * -> *). M m => m State get forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $! State -> a f State state modify :: M m => (State -> State) -> m () modify :: forall (m :: * -> *). M m => (State -> State) -> m () modify State -> State f = do State st <- forall (m :: * -> *). M m => m State get forall (m :: * -> *). M m => State -> m () put forall a b. (a -> b) -> a -> b $! State -> State f State st modify_play_state :: M m => (PlayState -> PlayState) -> m () modify_play_state :: forall (m :: * -> *). M m => (PlayState -> PlayState) -> m () modify_play_state PlayState -> PlayState f = forall (m :: * -> *). M m => (State -> State) -> m () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_play :: PlayState state_play = PlayState -> PlayState f (State -> PlayState state_play State st) } -- | Return the rect of the screen closest to the given point, or the default. get_screen :: M m => Maybe (Int, Int) -> m Rect.Rect get_screen :: forall (m :: * -> *). M m => Maybe (Int, Int) -> m Rect get_screen Maybe (Int, Int) mb_point = do [Rect] screens <- forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> [Rect] state_screens -- There are no screens yet during setup, so pick something somewhat -- reasonable so windows don't all try to crunch themselves down to -- nothing. forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a -> a fromMaybe (Int -> Int -> Int -> Int -> Rect Rect.xywh Int 0 Int 0 Int 800 Int 600) forall a b. (a -> b) -> a -> b $ case Maybe (Int, Int) mb_point of Maybe (Int, Int) Nothing -> forall a. [a] -> Maybe a Lists.head [Rect] screens Just (Int, Int) point -> forall k a. Ord k => (a -> k) -> [a] -> Maybe a Lists.minimumOn ((Int, Int) -> Rect -> Double Rect.distance (Int, Int) point) [Rect] screens lookup_performance :: M m => BlockId -> m (Maybe Performance) lookup_performance :: forall (m :: * -> *). M m => BlockId -> m (Maybe Performance) lookup_performance BlockId block_id = forall (m :: * -> *) a. M m => (State -> a) -> m a gets forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup BlockId block_id forall b c a. (b -> c) -> (a -> b) -> a -> c . PlayState -> Map BlockId Performance state_performance forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> PlayState state_play get_performance :: M m => BlockId -> m Performance get_performance :: forall (m :: * -> *). M m => BlockId -> m Performance get_performance BlockId block_id = forall (m :: * -> *) a. M m => Maybe a -> m a abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => BlockId -> m (Maybe Performance) lookup_performance BlockId block_id -- | Clear all performances, which will cause them to be rederived. -- This is stronger than 'Ui.update_all', because Ui.update_all will simply -- cause diff to look at the blocks for diffs, while this will force a -- re-derivation even if there are no apparent diffs. invalidate_performances :: M m => m () invalidate_performances :: forall (m :: * -> *). M m => m () invalidate_performances = forall (m :: * -> *). M m => (PlayState -> PlayState) -> m () modify_play_state forall a b. (a -> b) -> a -> b $ \PlayState state -> PlayState state { state_performance :: Map BlockId Performance state_performance = forall a. Monoid a => a mempty , state_current_performance :: Map BlockId Performance state_current_performance = forall a. Monoid a => a mempty } clear_im_cache :: BlockId -> CmdT IO () clear_im_cache :: BlockId -> CmdT IO () clear_im_cache BlockId block_id = do String path <- forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> String score_path forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ do Config config <- IO Config Shared.Config.getConfig let imDir :: String imDir = Config -> String Shared.Config.imDir Config config forall a. IO a -> IO (Maybe a) Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b $ String -> IO () Directory.removeDirectoryRecursive forall a b. (a -> b) -> a -> b $ String -> String -> BlockId -> String Shared.Config.notesDirectory String imDir String path BlockId block_id forall a. IO a -> IO (Maybe a) Exceptions.ignoreEnoent forall a b. (a -> b) -> a -> b $ String -> IO () Directory.removeDirectoryRecursive forall a b. (a -> b) -> a -> b $ String -> String -> BlockId -> String Shared.Config.outputDirectory String imDir String path BlockId block_id forall (m :: * -> *) a. Monad m => a -> m a return () -- | Keys currently held down, as in 'state_keys_down'. keys_down :: M m => m (Map Modifier Modifier) keys_down :: forall (m :: * -> *). M m => m (Map Modifier Modifier) keys_down = forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> Map Modifier Modifier state_keys_down get_focused_view :: M m => m ViewId get_focused_view :: forall (m :: * -> *). M m => m ViewId get_focused_view = forall (m :: * -> *) a. M m => Maybe a -> m a abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> Maybe ViewId state_focused_view get_focused_block :: M m => m BlockId get_focused_block :: forall (m :: * -> *). M m => m BlockId get_focused_block = View -> BlockId Block.view_block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (forall (m :: * -> *). M m => ViewId -> m View Ui.get_view forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => m ViewId get_focused_view) lookup_focused_view :: M m => m (Maybe ViewId) lookup_focused_view :: forall (m :: * -> *). M m => m (Maybe ViewId) lookup_focused_view = forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> Maybe ViewId state_focused_view -- | In some circumstances I don't want to abort if there's no focused block. lookup_focused_block :: M m => m (Maybe BlockId) lookup_focused_block :: forall (m :: * -> *). M m => m (Maybe BlockId) lookup_focused_block = do Maybe ViewId maybe_view_id <- forall (m :: * -> *). M m => m (Maybe ViewId) lookup_focused_view case Maybe ViewId maybe_view_id of -- It's still an error if the view id doesn't exist. Just ViewId view_id -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . View -> BlockId Block.view_block) (forall (m :: * -> *). M m => ViewId -> m View Ui.get_view ViewId view_id) Maybe ViewId Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing -- | Request focus. 'state_focused_view' will be updated once fltk reports the -- focus change. focus :: Ui.M m => ViewId -> m () focus :: forall (m :: * -> *). M m => ViewId -> m () focus ViewId view_id = do Maybe View view <- forall (m :: * -> *). M m => ViewId -> m (Maybe View) Ui.lookup_view ViewId view_id case Maybe View view of Maybe View Nothing -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a Ui.throw forall a b. (a -> b) -> a -> b $ Text "Cmd.focus on non-existent view: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Text showt ViewId view_id Maybe View _ -> forall (m :: * -> *) a. Monad m => a -> m a return () forall (m :: * -> *). M m => UiDamage -> m () Ui.damage forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { _bring_to_front :: Set ViewId Update._bring_to_front = forall a. a -> Set a Set.singleton ViewId view_id } get_current_step :: M m => m TimeStep.TimeStep get_current_step :: forall (m :: * -> *). M m => m TimeStep get_current_step = forall (m :: * -> *) a. M m => (State -> a) -> m a gets (EditState -> TimeStep state_time_step forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> EditState state_edit) -- | Get the leftmost track covered by the insert selection, which is -- considered the "focused" track by convention. get_insert_tracknum :: M m => m (Maybe TrackNum) get_insert_tracknum :: forall (m :: * -> *). M m => m (Maybe Int) get_insert_tracknum = do ViewId view_id <- forall (m :: * -> *). M m => m ViewId get_focused_view Maybe Selection sel <- forall (m :: * -> *). M m => ViewId -> Int -> m (Maybe Selection) Ui.get_selection ViewId view_id Int Config.insert_selnum -- Selection.shift can put the selection on or before the ruler track, so -- it doesn't get squished by going off the edge, but I don't want to ever -- act like <=0 is selected. forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Ord a => a -> a -> a max Int 1 forall b c a. (b -> c) -> (a -> b) -> a -> c . Selection -> Int Sel.start_track forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe Selection sel -- *** status -- | This just calls 'Ui.set_view_status', but all status setting should -- go through here so they can be uniformly filtered or logged or something. set_view_status :: M m => ViewId -> (Int, Text) -> Maybe Text -> m () set_view_status :: forall (m :: * -> *). M m => ViewId -> (Int, Text) -> Maybe Text -> m () set_view_status = forall (m :: * -> *). M m => ViewId -> (Int, Text) -> Maybe Text -> m () Ui.set_view_status -- | Emit a special log msg that will cause log view to put this key and value -- in its status bar. A value of \"\" will cause logview to delete that key. set_global_status :: M m => Text -> Text -> m () set_global_status :: forall (m :: * -> *). M m => Text -> Text -> m () set_global_status Text key Text val = do Map Text Text status_map <- forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> Map Text Text state_global_status forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Text key Map Text Text status_map forall a. Eq a => a -> a -> Bool /= forall a. a -> Maybe a Just Text val) forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *). M m => (State -> State) -> m () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_global_status :: Map Text Text state_global_status = forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Text key Text val Map Text Text status_map } forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.debug forall a b. (a -> b) -> a -> b $ Text "global status: " forall a. Semigroup a => a -> a -> a <> Text key forall a. Semigroup a => a -> a -> a <> Text " -- " forall a. Semigroup a => a -> a -> a <> Text val -- | Set a status variable on all views. set_status :: M m => (Int, Text) -> Maybe Text -> m () set_status :: forall (m :: * -> *). M m => (Int, Text) -> Maybe Text -> m () set_status (Int, Text) key Maybe Text val = do [ViewId] view_ids <- forall (m :: * -> *) a. M m => (State -> a) -> m a Ui.gets (forall k a. Map k a -> [k] Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Map ViewId View Ui.state_views) forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [ViewId] view_ids forall a b. (a -> b) -> a -> b $ \ViewId view_id -> forall (m :: * -> *). M m => ViewId -> (Int, Text) -> Maybe Text -> m () set_view_status ViewId view_id (Int, Text) key Maybe Text val -- ** lookup instrument -- | This is an instrument as looked up by 'lookup_instrument' or -- 'get_lookup_instrument'. This merges compiled-in and runtime instrument -- data. data ResolvedInstrument = ResolvedInstrument { ResolvedInstrument -> Inst inst_instrument :: !Inst , ResolvedInstrument -> Qualified inst_qualified :: !InstT.Qualified , ResolvedInstrument -> Config inst_common_config :: !Common.Config , ResolvedInstrument -> Backend inst_backend :: !Backend } deriving (Int -> ResolvedInstrument -> ShowS [ResolvedInstrument] -> ShowS ResolvedInstrument -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [ResolvedInstrument] -> ShowS $cshowList :: [ResolvedInstrument] -> ShowS show :: ResolvedInstrument -> String $cshow :: ResolvedInstrument -> String showsPrec :: Int -> ResolvedInstrument -> ShowS $cshowsPrec :: Int -> ResolvedInstrument -> ShowS Show) inst_synth :: ResolvedInstrument -> InstT.SynthName inst_synth :: ResolvedInstrument -> Text inst_synth = Qualified -> Text InstT.synth forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolvedInstrument -> Qualified inst_qualified inst_common :: ResolvedInstrument -> Common.Common InstrumentCode inst_common :: ResolvedInstrument -> Common InstrumentCode inst_common = forall code. Inst code -> Common code Inst.inst_common forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolvedInstrument -> Inst inst_instrument instance Pretty ResolvedInstrument where format :: ResolvedInstrument -> Doc format (ResolvedInstrument Inst instrument Qualified qualified Config common_config Backend backend) = Doc -> [(Text, Doc)] -> Doc Pretty.record Doc "ResolvedInstrument" [ (Text "instrument", forall a. Pretty a => a -> Doc Pretty.format Inst instrument) , (Text "qualified", forall a. Pretty a => a -> Doc Pretty.format Qualified qualified) , (Text "common_config", forall a. Pretty a => a -> Doc Pretty.format Config common_config) , (Text "backend", forall a. Pretty a => a -> Doc Pretty.format Backend backend) ] -- | This merges the compiled-id 'Inst.Backend' and the per-score -- 'UiConfig.Backend'. data Backend = Midi !Midi.Patch.Patch !Midi.Patch.Config | Im !Im.Patch.Patch | Sc !Sc.Patch.Patch | Dummy !Text deriving (Int -> Backend -> ShowS [Backend] -> ShowS Backend -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Backend] -> ShowS $cshowList :: [Backend] -> ShowS show :: Backend -> String $cshow :: Backend -> String showsPrec :: Int -> Backend -> ShowS $cshowsPrec :: Int -> Backend -> ShowS Show) instance Pretty Backend where format :: Backend -> Doc format (Midi Patch patch Config config) = forall a. Pretty a => a -> Doc Pretty.format (Patch patch, Config config) format (Im Patch patch) = forall a. Pretty a => a -> Doc Pretty.format Patch patch format (Sc Patch patch) = forall a. Pretty a => a -> Doc Pretty.format Patch patch format (Dummy Text msg) = Doc "Dummy \"" forall a. Semigroup a => a -> a -> a <> Text -> Doc Pretty.text Text msg forall a. Semigroup a => a -> a -> a <> Doc "\"" midi_patch :: ResolvedInstrument -> Maybe (Patch.Patch, Patch.Config) midi_patch :: ResolvedInstrument -> Maybe (Patch, Config) midi_patch ResolvedInstrument inst = case ResolvedInstrument -> Backend inst_backend ResolvedInstrument inst of Midi Patch patch Config config -> forall a. a -> Maybe a Just (Patch patch, Config config) Backend _ -> forall a. Maybe a Nothing sc_patch :: ResolvedInstrument -> Maybe Sc.Patch.Patch sc_patch :: ResolvedInstrument -> Maybe Patch sc_patch ResolvedInstrument inst = case ResolvedInstrument -> Backend inst_backend ResolvedInstrument inst of Sc Patch patch -> forall a. a -> Maybe a Just Patch patch Backend _ -> forall a. Maybe a Nothing get_midi_instrument :: (CallStack.Stack, M m) => ScoreT.Instrument -> m (Patch.Patch, Patch.Config) get_midi_instrument :: forall (m :: * -> *). (Stack, M m) => Instrument -> m (Patch, Config) get_midi_instrument Instrument inst = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a require (Text "not a midi instrument: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Instrument inst) forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolvedInstrument -> Maybe (Patch, Config) midi_patch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). (Stack, M m) => Instrument -> m ResolvedInstrument get_instrument Instrument inst lookup_midi_config :: M m => ScoreT.Instrument -> m (Maybe Patch.Config) lookup_midi_config :: forall (m :: * -> *). M m => Instrument -> m (Maybe Config) lookup_midi_config Instrument inst = forall (m :: * -> *) a b. Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) justm (forall (m :: * -> *). M m => Instrument -> m (Maybe Backend) lookup_backend Instrument inst) forall a b. (a -> b) -> a -> b $ \case Midi Patch _ Config config -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just Config config Backend _ -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing lookup_backend :: M m => ScoreT.Instrument -> m (Maybe Backend) lookup_backend :: forall (m :: * -> *). M m => Instrument -> m (Maybe Backend) lookup_backend Instrument inst = forall (m :: * -> *) a b. Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) justm (forall (m :: * -> *). M m => Instrument -> m (Maybe ResolvedInstrument) lookup_instrument Instrument inst) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolvedInstrument -> Backend inst_backend lookup_instrument :: M m => ScoreT.Instrument -> m (Maybe ResolvedInstrument) lookup_instrument :: forall (m :: * -> *). M m => Instrument -> m (Maybe ResolvedInstrument) lookup_instrument Instrument inst = do State ui_state <- forall (m :: * -> *). M m => m State Ui.get InstrumentDb db <- forall (m :: * -> *) a. M m => (State -> a) -> m a gets forall a b. (a -> b) -> a -> b $ Config -> InstrumentDb config_instrument_db forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> Config state_config case Instrument -> Lens State (Maybe Allocation) Ui.allocation Instrument inst forall f a. Lens f a -> f -> a #$ State ui_state of Maybe Allocation Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing Just Allocation alloc -> case InstrumentDb -> Allocation -> Either Text ResolvedInstrument resolve_instrument InstrumentDb db Allocation alloc of Left Text err -> do -- This is a broken allocation, so I should log it at least. forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.warn forall a b. (a -> b) -> a -> b $ Text "lookup " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Instrument inst forall a. Semigroup a => a -> a -> a <> Text ": " forall a. Semigroup a => a -> a -> a <> Text err forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing Right ResolvedInstrument val -> forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just ResolvedInstrument val) get_instrument :: (CallStack.Stack, M m) => ScoreT.Instrument -> m ResolvedInstrument get_instrument :: forall (m :: * -> *). (Stack, M m) => Instrument -> m ResolvedInstrument get_instrument Instrument inst = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a require (Text "instrument not found: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Instrument inst) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => Instrument -> m (Maybe ResolvedInstrument) lookup_instrument Instrument inst get_lookup_instrument :: M m => m (ScoreT.Instrument -> Maybe ResolvedInstrument) get_lookup_instrument :: forall (m :: * -> *). M m => m (Instrument -> Maybe ResolvedInstrument) get_lookup_instrument = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a b. a -> b -> a const forall a. Maybe a Nothing) forall a. a -> Maybe a Just .) forall a b. (a -> b) -> a -> b $ State -> State -> Instrument -> Either Text ResolvedInstrument state_lookup_instrument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *). M m => m State Ui.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (m :: * -> *). M m => m State get -- This throws away the Left error just because that's what its callers all -- happen to want. state_lookup_instrument :: Ui.State -> State -> ScoreT.Instrument -> Either Text ResolvedInstrument state_lookup_instrument :: State -> State -> Instrument -> Either Text ResolvedInstrument state_lookup_instrument State ui_state State cmd_state = Allocations -> InstrumentDb -> Instrument -> Either Text ResolvedInstrument memoized_instrument (Config -> Allocations UiConfig.config_allocations (State -> Config Ui.state_config State ui_state)) (Config -> InstrumentDb config_instrument_db (State -> Config state_config State cmd_state)) -- | This memoizes instrument resolution in case you're going to do it a lot. -- 'resolve_instrument' has to merge some things so it's not exactly free. -- The spine-strict Map makes this less efficient for one-off lookups, but so -- far all uses are mapping the lookup across many events. -- -- Of course, the memoization only works as long as the memo table persists, -- which should happen if you use 'get_lookup_instrument' and reuse the -- function it returns. memoized_instrument :: UiConfig.Allocations -> InstrumentDb -> ScoreT.Instrument -> Either Text ResolvedInstrument memoized_instrument :: Allocations -> InstrumentDb -> Instrument -> Either Text ResolvedInstrument memoized_instrument (UiConfig.Allocations Map Instrument Allocation allocs) InstrumentDb db = \Instrument inst -> forall a. a -> Maybe a -> a fromMaybe (forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Text "no alloc for " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Instrument inst) forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Instrument inst Map Instrument (Either Text ResolvedInstrument) memo where memo :: Map Instrument (Either Text ResolvedInstrument) memo = Allocation -> Either Text ResolvedInstrument resolve forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Map Instrument Allocation allocs resolve :: Allocation -> Either Text ResolvedInstrument resolve Allocation alloc = InstrumentDb -> Allocation -> Either Text ResolvedInstrument resolve_instrument InstrumentDb db Allocation alloc -- | See 'ResolvedInstrument'. resolve_instrument :: InstrumentDb -> UiConfig.Allocation -> Either Text ResolvedInstrument resolve_instrument :: InstrumentDb -> Allocation -> Either Text ResolvedInstrument resolve_instrument InstrumentDb db Allocation alloc = do let qualified :: Qualified qualified = Allocation -> Qualified UiConfig.alloc_qualified Allocation alloc Inst inst <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a tryJust (Text "patch not in db: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Qualified qualified) forall a b. (a -> b) -> a -> b $ Qualified -> InstrumentDb -> Maybe Inst inst_lookup Qualified qualified InstrumentDb db Backend backend <- case (forall code. Inst code -> Backend Inst.inst_backend Inst inst, Allocation -> Backend UiConfig.alloc_backend Allocation alloc) of (Inst.Midi Patch patch, UiConfig.Midi Config config) -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Patch -> Config -> Backend Midi Patch patch (Patch -> Config -> Config Patch.merge_defaults Patch patch Config config) (Inst.Im Patch patch, Backend UiConfig.Im) -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Patch -> Backend Im Patch patch (Inst.Sc Patch patch, Backend UiConfig.Sc) -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Patch -> Backend Sc Patch patch (Inst.Dummy Text msg1, UiConfig.Dummy Text msg2) -> -- If it's a dummy allocation of a dummy patch, then I can use "" -- to use the patch's msg. forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Text -> Backend Dummy forall a b. (a -> b) -> a -> b $ if Text msg2 forall a. Eq a => a -> a -> Bool /= Text "" then Text msg2 else Text msg1 -- 'UiConfig.verify_allocation' should have prevented this. (Backend inst_backend, Backend alloc_backend) -> forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ Text "inconsistent backends: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Backend inst_backend, Backend alloc_backend) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ ResolvedInstrument { inst_instrument :: Inst inst_instrument = Inst inst -- merge_call_map backend inst , inst_qualified :: Qualified inst_qualified = Qualified qualified , inst_common_config :: Config inst_common_config = Common InstrumentCode -> Config -> Config merge_environ (forall code. Inst code -> Common code Inst.inst_common Inst inst) (Allocation -> Config UiConfig.alloc_config Allocation alloc) , inst_backend :: Backend inst_backend = Backend backend } where -- Merge instrument default environ with the local Allocation. -- I used to use Maybe and replace when it was Just, but it turns out -- I definitely want to merge things like inst-top and inst-bottom. -- This means I can't delete keys, but if I ever need that I could -- do something like map to NotGiven. merge_environ :: Common.Common InstrumentCode -> Common.Config -> Common.Config merge_environ :: Common InstrumentCode -> Config -> Config merge_environ Common InstrumentCode common = Config :-> Environ Common.cenviron forall f a. Lens f a -> (a -> a) -> f -> f %= (forall code. Common code -> Environ Common.common_environ Common InstrumentCode common <>) -- TODO: I'm not sure if I want this or not... now Convert converts all -- attrs, while this had the effect of only converting supported ones. -- Which seems generally nice, so I'll leave the code here. -- Put the attrs the instrument understands in the CallMap as +attr calls. -- If there isn't already a higher level call in there, then at least we -- don't lose the attrs entirely. merge_call_map :: Backend -> Inst code -> Inst code merge_call_map Backend backend = forall {code}. Inst code :-> Common code Inst.commonforall a b c. Lens a b -> Lens b c -> Lens a c #forall {code}. Common code :-> CallMap Common.call_map forall f a. Lens f a -> (a -> a) -> f -> f %= (forall a. Semigroup a => a -> a -> a <> forall {a}. (Ord a, Monoid a, ShowVal a) => [a] -> Map a Symbol attr_calls (Backend -> [Attributes] inst_attrs Backend backend)) attr_calls :: [a] -> Map a Symbol attr_calls [a] attrs = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ (a attr, Text -> Symbol Expr.Symbol forall a b. (a -> b) -> a -> b $ forall a. ShowVal a => a -> Text ShowVal.show_val a attr) | a attr <- [a] attrs, a attr forall a. Eq a => a -> a -> Bool /= forall a. Monoid a => a mempty ] inst_attrs :: Backend -> [Attributes] inst_attrs = \case Midi Patch patch Config _ -> forall a. AttributeMap a -> [Attributes] Common.mapped_attributes forall a b. (a -> b) -> a -> b $ Patch -> AttributeMap Midi.Patch.patch_attribute_map Patch patch Im Patch patch -> forall a. AttributeMap a -> [Attributes] Common.mapped_attributes forall a b. (a -> b) -> a -> b $ Patch -> AttributeMap Im.Patch.patch_attribute_map Patch patch Sc Patch _patch -> forall a. Monoid a => a mempty -- TODO attrs for sc? Dummy {} -> forall a. Monoid a => a mempty -- ** lookup qualified name get_qualified :: M m => InstT.Qualified -> m Inst get_qualified :: forall (m :: * -> *). M m => Qualified -> m Inst get_qualified Qualified qualified = forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a require (Text "patch not in db: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Qualified qualified) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (m :: * -> *). M m => Qualified -> m (Maybe Inst) lookup_qualified Qualified qualified get_alloc_qualified :: M m => UiConfig.Allocation -> m Inst get_alloc_qualified :: forall (m :: * -> *). M m => Allocation -> m Inst get_alloc_qualified = forall (m :: * -> *). M m => Qualified -> m Inst get_qualified forall b c a. (b -> c) -> (a -> b) -> a -> c . Allocation -> Qualified UiConfig.alloc_qualified -- | Look up an instrument that might not be allocated. lookup_qualified :: M m => InstT.Qualified -> m (Maybe Inst) lookup_qualified :: forall (m :: * -> *). M m => Qualified -> m (Maybe Inst) lookup_qualified Qualified qualified = do Config config <- forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> Config state_config forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Qualified -> InstrumentDb -> Maybe Inst inst_lookup Qualified qualified (Config -> InstrumentDb config_instrument_db Config config) get_lookup_backend :: State -> InstT.Qualified -> Maybe Inst.Backend get_lookup_backend :: State -> Qualified -> Maybe Backend get_lookup_backend State state Qualified qualified = forall code. Inst code -> Backend Inst.inst_backend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Qualified -> InstrumentDb -> Maybe Inst inst_lookup Qualified qualified (Config -> InstrumentDb config_instrument_db (State -> Config state_config State state)) inst_lookup :: InstT.Qualified -> InstrumentDb -> Maybe Inst inst_lookup :: Qualified -> InstrumentDb -> Maybe Inst inst_lookup Qualified qualified InstrumentDb db | Qualified qualified forall a. Eq a => a -> a -> Bool == Qualified InstT.dummy = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall code. Backend -> Common code -> Inst code Inst.Inst (Text -> Backend Inst.Dummy Text "") (forall code. code -> Common code Common.common InstrumentCode empty_code) | Bool otherwise = forall code. Qualified -> Db code -> Maybe (Inst code) Inst.lookup Qualified qualified InstrumentDb db -- ** misc get_wdev_state :: M m => m WriteDeviceState get_wdev_state :: forall (m :: * -> *). M m => m WriteDeviceState get_wdev_state = forall (m :: * -> *) a. M m => (State -> a) -> m a gets State -> WriteDeviceState state_wdev_state modify_wdev_state :: M m => (WriteDeviceState -> WriteDeviceState) -> m () modify_wdev_state :: forall (m :: * -> *). M m => (WriteDeviceState -> WriteDeviceState) -> m () modify_wdev_state WriteDeviceState -> WriteDeviceState f = forall (m :: * -> *). M m => (State -> State) -> m () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_wdev_state :: WriteDeviceState state_wdev_state = WriteDeviceState -> WriteDeviceState f (State -> WriteDeviceState state_wdev_state State st) } derive_immediately :: M m => [BlockId] -> m () derive_immediately :: forall (m :: * -> *). M m => [BlockId] -> m () derive_immediately [BlockId] block_ids = forall (m :: * -> *). M m => (State -> State) -> m () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_derive_immediately :: Set BlockId state_derive_immediately = forall a. Ord a => [a] -> Set a Set.fromList [BlockId] block_ids forall a. Semigroup a => a -> a -> a <> State -> Set BlockId state_derive_immediately State st } inflict_damage :: M m => Derive.ScoreDamage -> m () inflict_damage :: forall (m :: * -> *). M m => ScoreDamage -> m () inflict_damage ScoreDamage damage = forall (m :: * -> *). M m => (PlayState -> PlayState) -> m () modify_play_state forall a b. (a -> b) -> a -> b $ \PlayState st -> PlayState st { state_current_performance :: Map BlockId Performance state_current_performance = forall a b k. (a -> b) -> Map k a -> Map k b Map.map Performance -> Performance inflict (PlayState -> Map BlockId Performance state_current_performance PlayState st) } where inflict :: Performance -> Performance inflict Performance perf = Performance perf { perf_damage :: ScoreDamage perf_damage = ScoreDamage damage forall a. Semigroup a => a -> a -> a <> Performance -> ScoreDamage perf_damage Performance perf } -- | Cause a block to rederive even if there haven't been any edits on it. inflict_block_damage :: M m => BlockId -> m () inflict_block_damage :: forall (m :: * -> *). M m => BlockId -> m () inflict_block_damage BlockId block_id = forall (m :: * -> *). M m => ScoreDamage -> m () inflict_damage forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { sdamage_blocks :: Set BlockId Derive.sdamage_blocks = forall a. a -> Set a Set.singleton BlockId block_id } -- | Cause a track to rederive even if there haven't been any edits on it. inflict_track_damage :: M m => BlockId -> TrackId -> m () inflict_track_damage :: forall (m :: * -> *). M m => BlockId -> TrackId -> m () inflict_track_damage BlockId block_id TrackId track_id = forall (m :: * -> *). M m => ScoreDamage -> m () inflict_damage forall a b. (a -> b) -> a -> b $ forall a. Monoid a => a mempty { sdamage_tracks :: Map TrackId (Ranges ScoreTime) Derive.sdamage_tracks = forall k a. k -> a -> Map k a Map.singleton TrackId track_id forall n. Ranges n Ranges.everything , sdamage_track_blocks :: Set BlockId Derive.sdamage_track_blocks = forall a. a -> Set a Set.singleton BlockId block_id } -- ** EditState modify_edit_state :: M m => (EditState -> EditState) -> m () modify_edit_state :: forall (m :: * -> *). M m => (EditState -> EditState) -> m () modify_edit_state EditState -> EditState f = forall (m :: * -> *). M m => (State -> State) -> m () modify forall a b. (a -> b) -> a -> b $ \State st -> State st { state_edit :: EditState state_edit = EditState -> EditState f (State -> EditState state_edit State st) } -- | At the Ui level, the edit box is per-block, but I use it to indicate edit -- mode, which is global. So it gets stored in Cmd.State and must be synced -- with new blocks. set_edit_box :: M m => Block.Box -> Block.Box -> m () set_edit_box :: forall (m :: * -> *). M m => Box -> Box -> m () set_edit_box Box skel Box track = do forall (m :: * -> *). M m => (EditState -> EditState) -> m () modify_edit_state forall a b. (a -> b) -> a -> b $ \EditState st -> EditState st { state_edit_box :: (Box, Box) state_edit_box = (Box skel, Box track) } [BlockId] block_ids <- forall (m :: * -> *). M m => m [BlockId] Ui.all_block_ids forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [BlockId] block_ids forall a b. (a -> b) -> a -> b $ \BlockId bid -> forall (m :: * -> *). M m => BlockId -> Box -> Box -> m () Ui.set_edit_box BlockId bid Box skel Box track is_val_edit :: M m => m Bool is_val_edit :: forall (m :: * -> *). M m => m Bool is_val_edit = (forall a. Eq a => a -> a -> Bool == EditMode ValEdit) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. M m => (State -> a) -> m a gets (EditState -> EditMode state_edit_mode forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> EditState state_edit) is_kbd_entry :: M m => m Bool is_kbd_entry :: forall (m :: * -> *). M m => m Bool is_kbd_entry = forall (m :: * -> *) a. M m => (State -> a) -> m a gets (EditState -> Bool state_kbd_entry forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> EditState state_edit) set_note_text :: M m => Text -> m () set_note_text :: forall (m :: * -> *). M m => Text -> m () set_note_text Text text = do forall (m :: * -> *). M m => (EditState -> EditState) -> m () modify_edit_state forall a b. (a -> b) -> a -> b $ \EditState st -> EditState st { state_note_text :: Text state_note_text = Text text } forall (m :: * -> *). M m => (Int, Text) -> Maybe Text -> m () set_status (Int, Text) Config.status_note_text forall a b. (a -> b) -> a -> b $ if Text -> Bool Text.null Text text then forall a. Maybe a Nothing else forall a. a -> Maybe a Just Text text get_instrument_attributes :: M m => ScoreT.Instrument -> m Attrs.Attributes get_instrument_attributes :: forall (m :: * -> *). M m => Instrument -> m Attributes get_instrument_attributes Instrument inst = forall a. a -> Maybe a -> a fromMaybe forall a. Monoid a => a mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. M m => (State -> a) -> m a gets (forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Instrument inst forall b c a. (b -> c) -> (a -> b) -> a -> c . EditState -> Map Instrument Attributes state_instrument_attributes forall b c a. (b -> c) -> (a -> b) -> a -> c . State -> EditState state_edit) set_instrument_attributes :: M m => ScoreT.Instrument -> Attrs.Attributes -> m () set_instrument_attributes :: forall (m :: * -> *). M m => Instrument -> Attributes -> m () set_instrument_attributes Instrument inst Attributes attrs = forall (m :: * -> *). M m => (EditState -> EditState) -> m () modify_edit_state forall a b. (a -> b) -> a -> b $ \EditState st -> EditState st { state_instrument_attributes :: Map Instrument Attributes state_instrument_attributes = forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert Instrument inst Attributes attrs (EditState -> Map Instrument Attributes state_instrument_attributes EditState st) } -- * util -- | Give a name to a Cmd. The name is applied when the cmd returns so the -- names come out in call order, and it doesn't incur overhead for cmds that -- abort. name :: M m => Text -> m a -> m a name :: forall (m :: * -> *) a. M m => Text -> m a -> m a name Text s m a cmd = m a cmd forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall (m :: * -> *). M m => (State -> State) -> m () modify (\State st -> State st { state_history_collect :: HistoryCollect state_history_collect = (State -> HistoryCollect state_history_collect State st) { state_cmd_names :: [Text] state_cmd_names = Text s forall a. a -> [a] -> [a] : HistoryCollect -> [Text] state_cmd_names (State -> HistoryCollect state_history_collect State st) } }) -- | Like 'name', but also set the 'state_suppress_edit'. This will suppress -- history recording until the edit mode changes from the given one. suppress_history :: M m => EditMode -> Text -> m a -> m a suppress_history :: forall (m :: * -> *) a. M m => EditMode -> Text -> m a -> m a suppress_history EditMode mode Text name m a cmd = m a cmd forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall (m :: * -> *). M m => (State -> State) -> m () modify (\State st -> State st { state_history_collect :: HistoryCollect state_history_collect = (State -> HistoryCollect state_history_collect State st) { state_cmd_names :: [Text] state_cmd_names = Text name forall a. a -> [a] -> [a] : HistoryCollect -> [Text] state_cmd_names (State -> HistoryCollect state_history_collect State st) , state_suppress_edit :: Maybe EditMode state_suppress_edit = forall a. a -> Maybe a Just EditMode mode } }) -- | Log an event so that it can be clicked on in logview. log_event :: BlockId -> TrackId -> Event.Event -> Text log_event :: BlockId -> TrackId -> Event -> Text log_event BlockId block_id TrackId track_id Event event = UiFrame -> Text Stack.log_ui_frame (forall a. a -> Maybe a Just BlockId block_id, forall a. a -> Maybe a Just TrackId track_id, forall a. a -> Maybe a Just (Event -> (ScoreTime, ScoreTime) Event.range Event event)) -- | Turn off all sounding notes, reset controls. -- TODO clear out WriteDeviceState? all_notes_off :: M m => m () all_notes_off :: forall (m :: * -> *). M m => m () all_notes_off = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall (m :: * -> *). M m => Thru -> m () write_thru [ Message -> Thru MidiThru forall a b. (a -> b) -> a -> b $ RealTime -> Message Midi.Interface.AllNotesOff RealTime 0 , Message -> Thru MidiThru forall a b. (a -> b) -> a -> b $ RealTime -> Message Interface.reset_controls RealTime 0 , Message -> Thru ImThru Message Thru.Stop ]