-- 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 CPP #-}
{- | The responder is the main event loop on the haskell side.

    It receives msgs (described in Cmd.Msg) multiplexed through a set of
    channels which come from various sources: the UI event loop (in its own
    thread), a socket, the MIDI library, etc.  The Msgs are then dispatched
    through Cmds to treat as they will, stopping when one returns Cmd.Done.

    The responder then deals with the results of the Cmds: midi thru output is
    sent and the old state is diffed with the new state to produce Updates,
    which are given to Sync to sync the visible UI with the changes the Cmds
    made to the UI state.
-}
module Cmd.Responder (
    create_msg_reader, responder

#ifdef TESTING
    , respond, State(..)
#endif
) where
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TChan as TChan
import qualified Control.Exception as Exception
import qualified Control.Monad.Except as Except
import qualified Control.Monad.State.Strict as Monad.State

import qualified Data.Map as Map
import qualified Data.Text.IO as Text.IO
import qualified Network.Socket as Socket
import qualified System.IO as IO

import qualified Util.Debug as Debug
import qualified Util.Log as Log
import qualified Util.Rect as Rect
import qualified Util.Thread as Thread
import qualified Util.Trace as Trace

import qualified App.Config as Config
import qualified App.Path as Path
import qualified App.ReplProtocol as ReplProtocol
import qualified App.StaticConfig as StaticConfig

import qualified Cmd.Cmd as Cmd
import qualified Cmd.GlobalKeymap as GlobalKeymap
import qualified Cmd.Integrate as Integrate
import qualified Cmd.Internal as Internal
import qualified Cmd.Ky as Ky
import qualified Cmd.Msg as Msg
import qualified Cmd.Performance as Performance
import qualified Cmd.PlayC as PlayC
import qualified Cmd.Repl as Repl
import qualified Cmd.ResponderSync as ResponderSync
import qualified Cmd.Save as Save
import qualified Cmd.SaveGitT as SaveGitT
import qualified Cmd.SyncKeycaps as SyncKeycaps
import qualified Cmd.TimeStep as TimeStep
import qualified Cmd.Track as Track
import qualified Cmd.Undo as Undo

import qualified Midi.Interface as Interface
import qualified Midi.Midi as Midi
import qualified Perform.Sc.Play as Sc.Play
import qualified Perform.Transport as Transport
import qualified Synth.Shared.Thru as Shared.Thru
import qualified Ui.Diff as Diff
import qualified Ui.Fltk as Fltk
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Sync as Sync
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           Control.Monad
import           Global
import           Types


data State = State {
    State -> StaticConfig
state_static_config :: StaticConfig.StaticConfig
    , State -> State
state_ui :: Ui.State
    , State -> State
state_cmd :: Cmd.State
    -- | Channel to send IO actions to be executed on the FLTK event loop.
    , State -> Channel
state_ui_channel :: Fltk.Channel
    -- | State for the repl subsystem.
    , State -> Session
state_session :: Repl.Session
    -- | This is used to feed msgs back into the MsgReader.
    , State -> Loopback
state_loopback :: Loopback
    -- | This function takes diffs and actually applies them to the UI.  It's
    -- passed as an argument so tests can run the responder without a UI.
    , State -> Sync
state_sync :: ResponderSync.Sync

    -- | Communication channel between the play monitor thread and the player,
    -- passed to 'Transport.info_state'.
    , State -> MVar State
state_monitor_state :: MVar.MVar Ui.State
    }

state_transport_info :: State -> Transport.Info
state_transport_info :: State -> Info
state_transport_info State
state = Transport.Info
    { info_send_status :: Status -> IO ()
info_send_status = State -> Loopback
state_loopback State
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Msg
Msg.Transport
    , info_midi_writer :: Message -> IO ()
info_midi_writer = State -> Message -> IO ()
Cmd.state_midi_writer (State -> State
state_cmd State
state)
    , info_midi_abort :: IO ()
info_midi_abort = forall write_message. RawInterface write_message -> IO ()
Interface.abort Interface
interface
    , info_get_current_time :: IO RealTime
info_get_current_time = forall write_message. RawInterface write_message -> IO RealTime
Interface.now Interface
interface
    , info_state :: MVar State
info_state = State -> MVar State
state_monitor_state State
state
    }
    where
    interface :: Interface
interface = Config -> Interface
Cmd.config_midi_interface (State -> Config
Cmd.state_config (State -> State
state_cmd State
state))

type MsgReader = IO Msg.Msg
type Loopback = Msg.Msg -> IO ()

responder :: StaticConfig.StaticConfig -> SaveGitT.User -> [Rect.Rect]
    -> Fltk.Channel -> MsgReader -> Interface.Interface
    -> Cmd.CmdT IO Cmd.Status -> Repl.Session -> Loopback -> IO ()
responder :: StaticConfig
-> User
-> [Rect]
-> Channel
-> MsgReader
-> Interface
-> CmdT IO Status
-> Session
-> Loopback
-> IO ()
responder StaticConfig
config User
git_user [Rect]
screens Channel
ui_chan MsgReader
msg_reader Interface
midi_interface CmdT IO Status
setup_cmd
        Session
repl_session Loopback
loopback = do
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.debug Text
"start responder"
    State
ui_state <- IO State
Ui.create
    MVar State
monitor_state <- forall a. a -> IO (MVar a)
MVar.newMVar State
ui_state
    AppDir
app_dir <- IO AppDir
Path.get_app_dir
    Canonical
save_dir <- String -> IO Canonical
Path.canonical forall a b. (a -> b) -> a -> b
$ AppDir -> Relative -> String
Path.to_absolute AppDir
app_dir Relative
Config.save_dir
    let cmd_state :: State
cmd_state = [Rect] -> State -> State
setup_state [Rect]
screens forall a b. (a -> b) -> a -> b
$ Config -> State
Cmd.initial_state forall a b. (a -> b) -> a -> b
$
            AppDir -> Canonical -> Interface -> StaticConfig -> User -> Config
StaticConfig.cmd_config AppDir
app_dir Canonical
save_dir Interface
midi_interface StaticConfig
config
                User
git_user
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"respond_initialize"
    State
state <- CmdT IO Status -> State -> IO State
run_setup_cmd CmdT IO Status
setup_cmd forall a b. (a -> b) -> a -> b
$ State
        { state_static_config :: StaticConfig
state_static_config = StaticConfig
config
        , state_ui :: State
state_ui = State
ui_state
        , state_cmd :: State
state_cmd = State
cmd_state
        , state_ui_channel :: Channel
state_ui_channel = Channel
ui_chan
        , state_session :: Session
state_session = Session
repl_session
        , state_loopback :: Loopback
state_loopback = Loopback
loopback
        , state_sync :: Sync
state_sync = Channel -> Sync
Sync.sync Channel
ui_chan
        , state_monitor_state :: MVar State
state_monitor_state = MVar State
monitor_state
        }
    State -> MsgReader -> IO ()
respond_loop State
state MsgReader
msg_reader

-- | TODO This should probably go in StaticConfig, or better StaticConfig could
-- just directly provide the Cmd.State.  But it needs to take app_dir and
-- interface as args, so... too much work for now.
setup_state :: [Rect.Rect] -> Cmd.State -> Cmd.State
setup_state :: [Rect] -> State -> State
setup_state [Rect]
screens State
state = State
state
    { state_edit :: EditState
Cmd.state_edit = (State -> EditState
Cmd.state_edit State
state)
        { state_time_step :: TimeStep
Cmd.state_time_step = Step -> TimeStep
TimeStep.time_step forall a b. (a -> b) -> a -> b
$
            MarklistMatch -> Rank -> Step
TimeStep.AbsoluteMark MarklistMatch
TimeStep.AllMarklists Rank
Meter.Q
        }
    , state_hooks :: Hooks
Cmd.state_hooks = (State -> Hooks
Cmd.state_hooks State
state)
        { hooks_selection :: [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
Cmd.hooks_selection = [[(ViewId, Maybe TrackSelection)] -> CmdId ()]
Internal.default_selection_hooks }
    , state_screens :: [Rect]
Cmd.state_screens = [Rect]
screens
    }

-- | A special run-and-sync that runs before the respond loop gets started.
run_setup_cmd :: Cmd.CmdT IO Cmd.Status -> State -> IO State
run_setup_cmd :: CmdT IO Status -> State -> IO State
run_setup_cmd CmdT IO Status
cmd State
state = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ State -> ResponderM Result -> IO (Bool, State)
run_responder State
state forall a b. (a -> b) -> a -> b
$ do
    Maybe (Status, State, State)
result <- Bool
-> Text -> EitherCmd -> ResponderM (Maybe (Status, State, State))
run_continue Bool
True Text
"initial setup" forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ do
        CmdT IO Status
cmd
        forall (m :: * -> *). M m => (State -> State) -> m ()
Cmd.modify forall a b. (a -> b) -> a -> b
$ \State
st -> State
st
            { state_history :: History
Cmd.state_history = (State -> History
Cmd.state_history State
st)
                -- If the cmd set hist_last_cmd, don't override it.
                { hist_last_cmd :: Maybe LastCmd
Cmd.hist_last_cmd = History -> Maybe LastCmd
Cmd.hist_last_cmd (State -> History
Cmd.state_history State
st)
                    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just (Maybe Commit -> [Text] -> LastCmd
Cmd.Load forall a. Maybe a
Nothing [Text
"setup"])
                }
            }
        forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Status, State, State)
result forall a b. (a -> b) -> a -> b
$ \(Status
_, State
ui_state, State
cmd_state) -> do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ \RState
st ->
            RState
st { rstate_ui_to :: State
rstate_ui_to = State
ui_state, rstate_cmd_to :: State
rstate_cmd_to = State
cmd_state }
        StateT RState IO ()
run_sync_status
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Status
Cmd.Continue

send_derive_status :: Loopback -> BlockId -> Msg.DeriveStatus -> IO ()
send_derive_status :: Loopback -> BlockId -> DeriveStatus -> IO ()
send_derive_status Loopback
loopback BlockId
block_id DeriveStatus
status =
    Loopback
loopback (BlockId -> DeriveStatus -> Msg
Msg.DeriveStatus BlockId
block_id DeriveStatus
status)

-- | Create the MsgReader to pass to 'responder'.
create_msg_reader ::
    (Midi.ReadMessage -> Midi.ReadMessage) -> TChan.TChan Midi.ReadMessage
    -> Socket.Socket -> TChan.TChan UiMsg.UiMsg -> TChan.TChan Msg.Msg
    -> IO MsgReader
create_msg_reader :: (ReadMessage -> ReadMessage)
-> TChan ReadMessage
-> Socket
-> TChan UiMsg
-> TChan Msg
-> IO MsgReader
create_msg_reader ReadMessage -> ReadMessage
remap_rmsg TChan ReadMessage
midi_chan Socket
repl_socket TChan UiMsg
ui_chan TChan Msg
loopback_chan = do
    TChan (Handle, Query)
repl_chan <- forall a. IO (TChan a)
TChan.newTChanIO
    String -> IO () -> IO ThreadId
Thread.startLogged String
"accept repl socket" forall a b. (a -> b) -> a -> b
$ Socket -> TChan (Handle, Query) -> IO ()
accept_loop Socket
repl_socket TChan (Handle, Query)
repl_chan
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$
        (UiMsg -> Msg
Msg.Ui forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
TChan.readTChan TChan UiMsg
ui_chan)
        forall a. STM a -> STM a -> STM a
`STM.orElse` (ReadMessage -> Msg
Msg.Midi forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadMessage -> ReadMessage
remap_rmsg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
TChan.readTChan TChan ReadMessage
midi_chan)
        forall a. STM a -> STM a -> STM a
`STM.orElse` (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Handle -> Query -> Msg
Msg.Socket forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
TChan.readTChan TChan (Handle, Query)
repl_chan)
        forall a. STM a -> STM a -> STM a
`STM.orElse` (forall a. TChan a -> STM a
TChan.readTChan TChan Msg
loopback_chan)

-- | Accept a connection on the socket, read everything that comes over, then
-- place the socket and the read data on @output_chan@.  It's the caller's
-- responsibility to close the handle after it uses it to reply.
accept_loop :: Socket.Socket -> TChan.TChan (IO.Handle, ReplProtocol.Query)
    -> IO ()
accept_loop :: Socket -> TChan (Handle, Query) -> IO ()
accept_loop Socket
socket TChan (Handle, Query)
output_chan = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (Socket -> IO (Maybe (Handle, Query))
Repl.accept_msg Socket
socket) forall a b. (a -> b) -> a -> b
$
    forall a. STM a -> IO a
STM.atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TChan a -> a -> STM ()
TChan.writeTChan TChan (Handle, Query)
output_chan


-- * respond

-- | Kill the respond if it's taking too long.  This can happen if derive gets
-- stuck and you hit play, for instance.
--
-- 2 seconds is too short, initial REPL cmds can take that much time.
-- TODO find out why and fix it?  That might be hard because presumably it's
-- forcing a bunch of CAFs.
timeout :: Thread.Seconds
timeout :: Seconds
timeout = Seconds
5

respond_loop :: State -> MsgReader -> IO ()
respond_loop :: State -> MsgReader -> IO ()
respond_loop State
state MsgReader
msg_reader = do
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"wait"
    Msg
msg <- MsgReader
msg_reader forall a b. IO a -> IO b -> IO a
`Exception.onException` State -> IO ()
kill_threads State
state
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace forall a b. (a -> b) -> a -> b
$ String
"respond " forall a. Semigroup a => a -> a -> a
<> Text -> String
untxt (Msg -> Text
Msg.show_short Msg
msg)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State -> Bool
Cmd.state_debug (State -> State
state_cmd State
state)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
(Stack, MonadIO m, Pretty a) =>
Text -> a -> m ()
Debug.putp Text
"msg" Msg
msg
    Either SomeException (Maybe (Bool, State))
result <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try forall a b. (a -> b) -> a -> b
$ forall a. Seconds -> IO a -> IO (Maybe a)
Thread.timeout Seconds
timeout forall a b. (a -> b) -> a -> b
$ State -> Msg -> IO (Bool, State)
respond State
state Msg
msg
    case Either SomeException (Maybe (Bool, State))
result of
        Left (SomeException
exc :: Exception.SomeException) -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"exception caught in respond_loop: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc
            State -> MsgReader -> IO ()
respond_loop State
state MsgReader
msg_reader
        Right Maybe (Bool, State)
Nothing -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error Text
"respond timed out, derive might be stuck"
            State -> MsgReader -> IO ()
respond_loop State
state MsgReader
msg_reader
        Right (Just (Bool
quit, State
state))
            | Bool
quit -> State -> IO ()
kill_threads State
state
            | Bool
otherwise -> State -> MsgReader -> IO ()
respond_loop State
state MsgReader
msg_reader

-- | Kill any active performance threads.  If they are managing subprocesses,
-- this will make sure the subprocesses die too.
kill_threads :: State -> IO ()
kill_threads :: State -> IO ()
kill_threads = State -> IO ()
Cmd.kill_performance_threadsforall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
state_cmd

-- | State maintained for a single responder cycle.
data RState = RState {
    RState -> State
rstate_state :: !State
    -- | Pre rollback UI state, revert to this state if an exception is
    -- thrown, and diff from this state.
    , RState -> State
rstate_ui_from :: !Ui.State
    -- | Post rollback UI state, and diff to this state.
    , RState -> State
rstate_ui_to :: !Ui.State
    , RState -> State
rstate_cmd_from :: !Cmd.State
    , RState -> State
rstate_cmd_to :: !Cmd.State
    -- | Collect updates from each cmd.
    , RState -> UiDamage
rstate_ui_damage :: !Update.UiDamage
    }

make_rstate :: State -> RState
make_rstate :: State -> RState
make_rstate State
state = RState
    { rstate_state :: State
rstate_state = State
state
    , rstate_ui_from :: State
rstate_ui_from = State -> State
state_ui State
state
    , rstate_ui_to :: State
rstate_ui_to = State -> State
state_ui State
state
    , rstate_cmd_from :: State
rstate_cmd_from = State -> State
state_cmd State
state
    , rstate_cmd_to :: State
rstate_cmd_to = State -> State
state_cmd State
state
    , rstate_ui_damage :: UiDamage
rstate_ui_damage = forall a. Monoid a => a
mempty
    }

type ResponderM = Monad.State.StateT RState IO

newtype Done = Done Result

type Result = Either Ui.Error Cmd.Status

save_damage :: Update.UiDamage -> ResponderM ()
save_damage :: UiDamage -> StateT RState IO ()
save_damage UiDamage
damage = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ \RState
st ->
    RState
st { rstate_ui_damage :: UiDamage
rstate_ui_damage = UiDamage
damage forall a. Semigroup a => a -> a -> a
<> RState -> UiDamage
rstate_ui_damage RState
st }

-- ** run

{- | Run one responder cycle.  This is simple in theory: each cmd gets
    a crack at the Msg and the first one to return anything other than
    Continue aborts the sequence.  If a cmd throws an exception the sequence
    is also aborted, and changes to 'Cmd.State' or 'Ui.State' are
    discarded.  Otherwise, the UI state changes are synced with the UI, and
    the responder goes back to waiting for another msg.

    However, there are a number of complications.  Some cmds apply to either
    the cmd state or UI state *before* the rollback, so they don't get rolled
    back on an exception, and don't sync with the UI, or run after the last
    Done, but not after an exception.  Most cmds are pure, but there is
    a hardcoded set that require IO, and many of those need access to
    special state.  Rather than cluttering up Cmd.State for everyone, they
    are passed their special values directly.

    TODO I feel like this generates a lot of garbage per msg.  It mostly
    doesn't matter except for MIDI input.  Profile?
-}
run_responder :: State -> ResponderM Result -> IO (Bool, State)
run_responder :: State -> ResponderM Result -> IO (Bool, State)
run_responder State
state ResponderM Result
action = do
    (Result
val, RState State
_ State
ui_from State
ui_to State
cmd_from State
cmd_to UiDamage
ui_damage)
        <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Monad.State.runStateT ResponderM Result
action (State -> RState
make_rstate State
state)
    case Result
val of
        Left Error
err -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (forall a. Pretty a => a -> Text
pretty Error
err)
            -- Exception rolls back changes to ui_state and cmd_state.
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, State
state { state_ui :: State
state_ui = State
ui_from, state_cmd :: State
state_cmd = State
cmd_from })
        Right Status
status -> do
            -- overload "turned on debug" to dump fltk debugging
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (State -> Bool
Cmd.state_debug State
cmd_from) Bool -> Bool -> Bool
&& State -> Bool
Cmd.state_debug State
cmd_to) forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
Map.keys (State -> Map ViewId View
Ui.state_views State
ui_to)) forall a b. (a -> b) -> a -> b
$
                    Channel -> ViewId -> IO ()
Sync.print_debug (State -> Channel
state_ui_channel State
state)
            State
-> State
-> State
-> State
-> UiDamage
-> Status
-> IO (Bool, State)
post_cmd State
state State
ui_from State
ui_to State
cmd_to UiDamage
ui_damage Status
status

-- | Do all the miscellaneous things that need to be done after a command
-- completes.  This doesn't happen if the cmd threw an exception.
post_cmd :: State -> Ui.State -> Ui.State -> Cmd.State
    -> Update.UiDamage -> Cmd.Status -> IO (Bool, State)
post_cmd :: State
-> State
-> State
-> State
-> UiDamage
-> Status
-> IO (Bool, State)
post_cmd State
state State
ui_from State
ui_to State
cmd_to UiDamage
ui_damage Status
status = do
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"cmd"
    -- Load external definitions and cache them in Cmd.State, so cmds don't
    -- have a dependency on IO.
    (!State
ui_to, !State
cmd_to, [Msg]
logs) <- forall a. a -> Maybe a -> a
fromMaybe (State
ui_to, State
cmd_to, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        State -> State -> Text -> IO (Maybe (State, State, [Msg]))
Ky.update State
ui_to State
cmd_to (Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> Text
UiConfig.ky forall f a. Lens f a -> f -> a
#$ State
ui_to)
    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

    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"ky"
    !State
cmd_to <- Channel -> State -> State -> Info -> Status -> IO State
handle_special_status (State -> Channel
state_ui_channel State
state) State
ui_to State
cmd_to
        (State -> Info
state_transport_info State
state) Status
status
    !State
cmd_to <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State -> State -> State
fix_cmd_state State
ui_to State
cmd_to
    ([UiUpdate]
updates, State
ui_to) <- Sync
-> State
-> State
-> State
-> UiDamage
-> MVar State
-> IO ([UiUpdate], State)
ResponderSync.sync (State -> Sync
state_sync State
state)
        State
ui_from State
ui_to State
cmd_to UiDamage
ui_damage
        (Info -> MVar State
Transport.info_state (State -> Info
state_transport_info State
state))
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync"

    State
cmd_to <- do
        -- Kick off the background derivation threads.
        State
cmd_state <- (BlockId -> DeriveStatus -> IO ())
-> State -> State -> ScoreDamage -> IO State
Performance.update_performance
            (Loopback -> BlockId -> DeriveStatus -> IO ()
send_derive_status (State -> Loopback
state_loopback State
state)) State
ui_to State
cmd_to
            (State -> State -> UiDamage -> [UiUpdate] -> ScoreDamage
Diff.derive_diff (State -> State
state_ui State
state) State
ui_to UiDamage
ui_damage [UiUpdate]
updates)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
cmd_state { state_derive_immediately :: Set BlockId
Cmd.state_derive_immediately = forall a. Monoid a => a
mempty }
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"derive_diff"

    State
cmd_to <- State -> State -> [UiUpdate] -> IO State
Undo.maintain_history State
ui_to State
cmd_to [UiUpdate]
updates
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"undo"
    State
cmd_to <- Channel -> State -> IO State
sync_keycaps (State -> Channel
state_ui_channel State
state) State
cmd_to
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync_keycaps"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Bool
is_quit Status
status) forall a b. (a -> b) -> a -> b
$
        State -> State -> IO ()
Save.save_views State
cmd_to State
ui_to
            forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \(IOException
exc :: Exception.IOException) ->
                -- Otherwise there's no way to quit!
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"failed to write views while quitting: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt IOException
exc
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Status -> Bool
is_quit Status
status
        , State
state { state_ui :: State
state_ui = State
ui_to, state_cmd :: State
state_cmd = State
cmd_to }
        )
    where
    is_quit :: Status -> Bool
is_quit Status
Cmd.Quit = Bool
True
    is_quit Status
_ = Bool
False
    -- | If the focused view is removed, cmd state should stop pointing to it.
    fix_cmd_state :: Ui.State -> Cmd.State -> Cmd.State
    fix_cmd_state :: State -> State -> State
fix_cmd_state State
ui_state State
cmd_state = case State -> Maybe ViewId
Cmd.state_focused_view State
cmd_state of
        Just ViewId
focus | ViewId
focus forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` State -> Map ViewId View
Ui.state_views State
ui_state ->
            State
cmd_state { state_focused_view :: Maybe ViewId
Cmd.state_focused_view = forall a. Maybe a
Nothing }
        Maybe ViewId
_ -> State
cmd_state

handle_special_status :: Fltk.Channel -> Ui.State -> Cmd.State
    -> Transport.Info -> Cmd.Status -> IO Cmd.State
handle_special_status :: Channel -> State -> State -> Info -> Status -> IO State
handle_special_status Channel
ui_chan State
ui_state State
cmd_state Info
transport_info = \case
    Cmd.Play PlayArgs
args -> do
        -- Cancel an existing player if there is one.  Play.stop also does a
        -- stop_im, but I don't think that's necessary for im, it only plays
        -- one thing at a time anyway.
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PlayControl -> IO ()
Transport.stop_player forall a b. (a -> b) -> a -> b
$
            PlayState -> [PlayControl]
Cmd.state_play_control (State -> PlayState
Cmd.state_play State
cmd_state)
        PlayControl
play_ctl <- Channel -> State -> Info -> PlayArgs -> IO PlayControl
PlayC.play Channel
ui_chan State
ui_state Info
transport_info PlayArgs
args
        let play :: PlayState
play = State -> PlayState
Cmd.state_play State
cmd_state
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! State
cmd_state
            { state_play :: PlayState
Cmd.state_play = PlayState
play
                { state_play_control :: [PlayControl]
Cmd.state_play_control =
                    PlayControl
play_ctl forall a. a -> [a] -> [a]
: PlayState -> [PlayControl]
Cmd.state_play_control PlayState
play
                }
            }
    Cmd.FloatingInput FloatingInput
action -> do
        Channel -> Text -> Fltk () -> IO ()
Fltk.send_action Channel
ui_chan Text
"floating_input" forall a b. (a -> b) -> a -> b
$
            State -> FloatingInput -> Fltk ()
Sync.floating_input State
ui_state FloatingInput
action
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! State
cmd_state
            { state_edit :: EditState
Cmd.state_edit = (State -> EditState
Cmd.state_edit State
cmd_state)
                { state_floating_input :: Bool
Cmd.state_floating_input = Bool
True }
            }
    Status
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return State
cmd_state

respond :: State -> Msg.Msg -> IO (Bool, State)
respond :: State -> Msg -> IO (Bool, State)
respond State
state Msg
msg = State -> ResponderM Result -> IO (Bool, State)
run_responder State
state forall a b. (a -> b) -> a -> b
$ do
    Msg -> StateT RState IO ()
record_keys Msg
msg
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"keys"
    -- Normal cmds abort as son as one returns a non-Continue.
    Result
result <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Done Result -> Result
unerror forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall a b. (a -> b) -> a -> b
$ do
        Msg -> ErrorResponderM ()
record_ui_updates Msg
msg
        forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"ui_updates"
        Msg -> ErrorResponderM ()
run_core_cmds Msg
msg
        forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"core_cmds"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Status
Cmd.Done
    case Result
result of
        Right Status
_ -> StateT RState IO ()
run_sync_status
        Left Error
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync_status"
    forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
    where unerror :: Either Done Result -> Result
unerror = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(Done Result
r) -> Result
r) forall a. a -> a
id

-- * keycaps

sync_keycaps :: Fltk.Channel -> Cmd.State -> IO Cmd.State
sync_keycaps :: Channel -> State -> IO State
sync_keycaps Channel
ui_chan State
cmd_to = case State -> Maybe KeycapsUpdate
Cmd.state_keycaps_update State
cmd_to of
    Maybe KeycapsUpdate
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return State
cmd_to
    Just KeycapsUpdate
Cmd.KeycapsClose -> do
        Channel -> IO ()
Sync.destroy_keycaps Channel
ui_chan
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
cmd_to
            { state_keycaps :: Maybe KeycapsState
Cmd.state_keycaps = forall a. Maybe a
Nothing
            , state_keycaps_update :: Maybe KeycapsUpdate
Cmd.state_keycaps_update = forall a. Maybe a
Nothing
            }
    Just (Cmd.KeycapsUpdate KeycapsState
state Maybe ((Int, Int), Layout)
mb_window RawBindings
bindings) -> do
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ((Int, Int), Layout)
mb_window forall a b. (a -> b) -> a -> b
$ \((Int, Int)
pos, Layout
layout) ->
            Channel -> (Int, Int) -> Layout -> IO ()
Sync.create_keycaps Channel
ui_chan (Int, Int)
pos Layout
layout
        Channel -> RawBindings -> IO ()
Sync.update_keycaps Channel
ui_chan RawBindings
bindings
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
cmd_to
            { state_keycaps :: Maybe KeycapsState
Cmd.state_keycaps = forall a. a -> Maybe a
Just KeycapsState
state
            , state_keycaps_update :: Maybe KeycapsUpdate
Cmd.state_keycaps_update = forall a. Maybe a
Nothing
            }

-- ** special cmds

-- | The record keys cmd commits its changes to cmd_from, so if a later cmd
-- throws the key record won't be rolled back.
record_keys :: Msg.Msg -> ResponderM ()
record_keys :: Msg -> StateT RState IO ()
record_keys Msg
msg = do
    Maybe (Status, State, State)
result <- Bool
-> Text -> EitherCmd -> ResponderM (Maybe (Status, State, State))
run_continue Bool
False Text
"record_keys" forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => Msg -> m Status
Internal.cmd_record_keys Msg
msg
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Status, State, State)
result forall a b. (a -> b) -> a -> b
$ \(Status
_, State
_, State
cmd_state) -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ \RState
st ->
        RState
st { rstate_cmd_from :: State
rstate_cmd_from = State
cmd_state, rstate_cmd_to :: State
rstate_cmd_to = State
cmd_state }

-- | Record 'UiMsg.UiUpdate's from the UI.  Like normal cmds it can abort
-- processing by returning not-Continue, but it commits its changes to ui_from
-- instead of ui_to.  This means these changes don't participate in the diff
-- and sync.  This is because UiUpdates are reporting changes that already
-- happened, so they can't be rolled back and sending them back to the UI
-- would be silly.
record_ui_updates :: Msg.Msg -> ErrorResponderM ()
record_ui_updates :: Msg -> ErrorResponderM ()
record_ui_updates Msg
msg = do
    (Either Error (Status, State)
result, State
cmd_state) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ EitherCmd -> ResponderM (Either Error (Status, State), State)
run_cmd forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). M m => Msg -> m Status
Internal.cmd_record_ui_updates Msg
msg
    case Either Error (Status, State)
result of
        Left Error
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Result -> Done
Done (forall a b. a -> Either a b
Left Error
err)
        Right (Status
status, State
ui_state) -> do
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ \RState
st -> RState
st
                { rstate_ui_from :: State
rstate_ui_from = State
ui_state, rstate_ui_to :: State
rstate_ui_to = State
ui_state
                , rstate_cmd_to :: State
rstate_cmd_to = State
cmd_state
                }
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Bool
not_continue Status
status) forall a b. (a -> b) -> a -> b
$
                forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Result -> Done
Done (forall a b. b -> Either a b
Right Status
status)

-- | This runs after normal cmd processing to update various status displays.
-- It doesn't run after an exception, but *should* run after a Done.
--
-- TODO this could go in 'post_cmd', but then post_cmd would have to be in
-- ResponderM.
run_sync_status :: ResponderM ()
run_sync_status :: StateT RState IO ()
run_sync_status = do
    RState
rstate <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
    Maybe (Status, State, State)
result <- Bool
-> Text -> EitherCmd -> ResponderM (Maybe (Status, State, State))
run_continue Bool
False Text
"sync_status" forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). M m => m ()
SyncKeycaps.update
        State -> State -> UiDamage -> CmdId Status
Internal.sync_status (RState -> State
rstate_ui_from RState
rstate) (RState -> State
rstate_cmd_from RState
rstate)
            (RState -> UiDamage
rstate_ui_damage RState
rstate)
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Status, State, State)
result forall a b. (a -> b) -> a -> b
$ \(Status
_, State
ui_state, State
cmd_state) -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ \RState
st ->
        RState
st { rstate_ui_to :: State
rstate_ui_to = State
ui_state, rstate_cmd_to :: State
rstate_cmd_to = State
cmd_state }

-- ** core cmds

run_core_cmds :: Msg.Msg -> ErrorResponderM ()
run_core_cmds :: Msg -> ErrorResponderM ()
run_core_cmds Msg
msg = do
    State
state <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
Monad.State.gets RState -> State
rstate_state
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EitherCmd -> ErrorResponderM ()
run_throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$Msg
msg))
        (StaticConfig -> [Msg -> CmdT IO Status]
StaticConfig.global_cmds (State -> StaticConfig
state_static_config State
state))
    -- Focus commands and the rest of the pure commands come first so text
    -- entry can override io bound commands.
    let pure_cmds :: [Msg -> CmdId Status]
pure_cmds = [Msg -> CmdId Status]
hardcoded_cmds forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). M m => Handler m -> Msg -> m Status
Cmd.call Handler (CmdT Identity)
GlobalKeymap.pure_keymap]
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EitherCmd -> ErrorResponderM ()
run_throw 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
. (forall a b. (a -> b) -> a -> b
$Msg
msg)) [Msg -> CmdId Status]
pure_cmds
    -- Certain commands require IO.  Rather than make everything IO,
    -- I hardcode them in a special list that gets run in IO.
    let io_cmds :: [Msg -> CmdT IO Status]
io_cmds = Channel -> Session -> [Msg -> CmdT IO Status]
hardcoded_io_cmds (State -> Channel
state_ui_channel State
state)
            (State -> Session
state_session State
state)
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EitherCmd -> ErrorResponderM ()
run_throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$Msg
msg)) [Msg -> CmdT IO Status]
io_cmds

-- | These cmds always get the first shot at the Msg.
hardcoded_cmds :: [Msg.Msg -> Cmd.CmdId Cmd.Status]
hardcoded_cmds :: [Msg -> CmdId Status]
hardcoded_cmds =
    [ forall (m :: * -> *). M m => Msg -> m Status
Internal.record_focus
    , forall (m :: * -> *). M m => Msg -> m Status
Internal.update_ui_state
    , Msg -> CmdId Status
Track.track_cmd
    , forall (m :: * -> *). M m => Msg -> m Status
Integrate.cmd_integrate
    ]

-- | These are the only commands that run in IO.
hardcoded_io_cmds :: Fltk.Channel -> Repl.Session
    -> [Msg.Msg -> Cmd.CmdT IO Cmd.Status]
hardcoded_io_cmds :: Channel -> Session -> [Msg -> CmdT IO Status]
hardcoded_io_cmds Channel
ui_chan Session
repl_session =
    [ Session -> Msg -> CmdT IO Status
Repl.respond Session
repl_session
    , Channel -> Msg -> CmdT IO Status
PlayC.cmd_play_msg Channel
ui_chan
    , forall (m :: * -> *). M m => Handler m -> Msg -> m Status
Cmd.call Handler (CmdT IO)
GlobalKeymap.io_keymap
    ]

-- ** run cmds

type EitherCmd = Either (Cmd.CmdId Cmd.Status) (Cmd.CmdT IO Cmd.Status)
type ErrorResponderM = Except.ExceptT Done ResponderM

-- | Run a cmd and ignore the 'Cmd.Status', but log a complaint if it wasn't
-- Continue.
run_continue :: Bool -- ^ A special hack so I don't get confused when I typo
    -- a score filename.
    -> Text -> EitherCmd
    -> ResponderM (Maybe (Cmd.Status, Ui.State, Cmd.State))
run_continue :: Bool
-> Text -> EitherCmd -> ResponderM (Maybe (Status, State, State))
run_continue Bool
log_to_stderr Text
caller EitherCmd
cmd = do
    (Either Error (Status, State)
result, State
cmd_state) <- EitherCmd -> ResponderM (Either Error (Status, State), State)
run_cmd EitherCmd
cmd
    case Either Error (Status, State)
result of
        Left Error
err -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Error
err
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
log_to_stderr forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Error
err
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right (Status
status, State
ui_state) -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Bool
not_continue Status
status) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
caller forall a. Semigroup a => a -> a -> a
<> Text
": expected Continue: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Status
status
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Status
status, State
ui_state, State
cmd_state)

-- | Run a Cmd, throwing the 'Cmd.Status' if it wasn't Continue.
run_throw :: EitherCmd -> ErrorResponderM ()
run_throw :: EitherCmd -> ErrorResponderM ()
run_throw EitherCmd
cmd = do
    (Either Error (Status, State)
result, State
cmd_state) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ EitherCmd -> ResponderM (Either Error (Status, State), State)
run_cmd EitherCmd
cmd
    case Either Error (Status, State)
result of
        Left Error
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Result -> Done
Done (forall a b. a -> Either a b
Left Error
err)
        Right (Status
status, State
ui_state) -> do
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
Monad.State.modify forall a b. (a -> b) -> a -> b
$ \RState
st ->
                RState
st { rstate_ui_to :: State
rstate_ui_to = State
ui_state, rstate_cmd_to :: State
rstate_cmd_to = State
cmd_state }
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Bool
not_continue Status
status) forall a b. (a -> b) -> a -> b
$
                forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Result -> Done
Done (forall a b. b -> Either a b
Right Status
status)

run_cmd :: EitherCmd -> ResponderM
    (Either Ui.Error (Cmd.Status, Ui.State), Cmd.State)
run_cmd :: EitherCmd -> ResponderM (Either Error (Status, State), State)
run_cmd EitherCmd
cmd = do
    RState
rstate <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
    (State
cmd_state, [Thru]
thru, [Msg]
logs, Either Error (Status, State, UiDamage)
result) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case EitherCmd
cmd of
        Left CmdId Status
cmd ->
            RunCmd Identity IO Status
Cmd.run_id_io (RState -> State
rstate_ui_to RState
rstate) (RState -> State
rstate_cmd_to RState
rstate) CmdId Status
cmd
        Right CmdT IO Status
cmd ->
            RunCmd IO IO Status
Cmd.run_io (RState -> State
rstate_ui_to RState
rstate) (RState -> State
rstate_cmd_to RState
rstate) CmdT IO Status
cmd
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        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
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Message -> IO ()) -> Thru -> IO ()
write_thru (State -> Message -> IO ()
Cmd.state_midi_writer (RState -> State
rstate_cmd_to RState
rstate))) [Thru]
thru
    case Either Error (Status, State, UiDamage)
result of
        Left Error
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Error
err, State
cmd_state)
        Right (Status
status, State
ui_state, UiDamage
ui_damage) -> do
            UiDamage -> StateT RState IO ()
save_damage UiDamage
ui_damage
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Status
status, State
ui_state), State
cmd_state)

write_thru :: (Interface.Message -> IO ()) -> Cmd.Thru -> IO ()
write_thru :: (Message -> IO ()) -> Thru -> IO ()
write_thru Message -> IO ()
midi_writer = \case
    Cmd.MidiThru Message
msg -> Message -> IO ()
midi_writer Message
msg
    Cmd.ImThru Message
msg -> Message -> IO ()
Shared.Thru.send Message
msg
    Cmd.OscThru [OSC]
oscs -> [OSC] -> IO ()
Sc.Play.osc_thru [OSC]
oscs

not_continue :: Cmd.Status -> Bool
not_continue :: Status -> Bool
not_continue Status
Cmd.Continue = Bool
False
not_continue Status
_ = Bool
True