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

{- | Subset of the responder that handles syncing from Ui.State to the UI.
-}
module Cmd.ResponderSync (Sync, sync) where
import qualified Control.Concurrent.MVar as MVar
import qualified Data.Map as Map
import qualified Data.Text as Text

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

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Integrate as Integrate
import qualified Cmd.Internal as Internal

import qualified Ui.Diff as Diff
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.Update as Update

import           Global


type Sync = Track.TrackSignals -> Track.SetStyleHigh -> Ui.State
    -> [Update.DisplayUpdate] -> IO (Maybe Ui.Error)

-- | Sync @ui_to@ to the UI.
--
-- Returns both UI state and cmd state since verification may clean up the UI
-- state, and this is where the undo history is stored in Cmd.State.
sync :: Sync
    -> Ui.State -- ^ state before Cmd was run
    -> Ui.State -- ^ current state
    -> Cmd.State -> Update.UiDamage -> MVar.MVar Ui.State
    -> IO ([Update.UiUpdate], Ui.State)
    -- ^ Sync uses 'Update.DisplayUpdate's, but the diff also produces
    -- UiUpdates, which are needed for incremental save and score damage.
sync :: Sync
-> State
-> State
-> State
-> UiDamage
-> MVar State
-> IO ([UiUpdate], State)
sync Sync
sync_func State
ui_from State
ui_to State
cmd_to UiDamage
ui_damage MVar State
play_monitor_state = do
    State
ui_to <- case UiDamage -> State -> Either String (State, [Text])
Ui.quick_verify UiDamage
ui_damage State
ui_to of
        Left String
err -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"cmd caused a verify error, rejecting state change: "
                forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
err
            forall (m :: * -> *) a. Monad m => a -> m a
return State
ui_from
        Right (State
state, [Text]
warns) -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
warns) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"verify fixed issues: "
                    forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " [Text]
warns
            forall (m :: * -> *) a. Monad m => a -> m a
return State
state
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.verify"

    let ([UiUpdate]
ui_updates, [DisplayUpdate]
display_updates) = UiDamage -> State -> State -> ([UiUpdate], [DisplayUpdate])
Diff.diff UiDamage
ui_damage State
ui_from State
ui_to
    forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m ()
Trace.force ([UiUpdate]
ui_updates, [DisplayUpdate]
display_updates)
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.diff"
    -- Debug.fullM (Debug.putp "ui_damage") ui_damage
    -- Debug.fullM (Debug.putp "ui_updates") ui_updates
    -- Debug.fullM (Debug.putp "display_updates") display_updates

    (State
ui_to, [UiUpdate]
ui_updates, [DisplayUpdate]
display_updates) <-
        case [UiUpdate] -> State -> Either Error ([Msg], State, UiDamage)
Integrate.score_integrate [UiUpdate]
ui_updates State
ui_to of
            Left Error
err -> do
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"score_integrate failed: " 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 (State
ui_from, [UiUpdate]
ui_updates, [DisplayUpdate]
display_updates)
            Right ([Msg]
logs, State
state, UiDamage
updates) -> 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
                let ([UiUpdate]
ui_updates', [DisplayUpdate]
display_updates') =
                        UiDamage -> State -> State -> ([UiUpdate], [DisplayUpdate])
Diff.diff UiDamage
updates State
ui_to State
state
                forall (m :: * -> *) a. Monad m => a -> m a
return
                    ( State
state
                    , [UiUpdate]
ui_updates forall a. [a] -> [a] -> [a]
++ [UiUpdate]
ui_updates'
                    , [DisplayUpdate]
display_updates forall a. [a] -> [a] -> [a]
++ [DisplayUpdate]
display_updates'
                    )
    forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m ()
Trace.force ([UiUpdate]
ui_updates, [DisplayUpdate]
display_updates)
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.score_integrate"

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UiUpdate -> Bool
modified_view [UiUpdate]
ui_updates) forall a b. (a -> b) -> a -> b
$
        forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar State
play_monitor_state (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return State
ui_to))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State -> Bool
Cmd.state_debug State
cmd_to Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DisplayUpdate]
display_updates)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
(Stack, MonadIO m, Pretty a) =>
Text -> a -> m ()
Debug.putp Text
"updates" [DisplayUpdate]
display_updates
    Maybe Error
err <- Sync
sync_func (State -> TrackSignals
get_track_signals State
cmd_to) SetStyleHigh
Internal.set_style
        State
ui_to [DisplayUpdate]
display_updates
    forall (m :: * -> *). MonadIO m => String -> m ()
Trace.trace String
"sync.sync"
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Error
err forall a b. (a -> b) -> a -> b
$ \Error
err ->
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"syncing updates: " 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 ([UiUpdate]
ui_updates, State
ui_to)

-- | Get all track signals already derived.  TrackSignals are only collected
-- for top level derives, so there should only be signals for visible windows.
-- If the derive is still in progress, there may not be signals, but they will
-- be directly when the DeriveComplete is received.
get_track_signals :: Cmd.State -> Track.TrackSignals
get_track_signals :: State -> TrackSignals
get_track_signals = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap Performance -> TrackSignals
Cmd.perf_track_signals 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 Performance
Cmd.state_performance forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> PlayState
Cmd.state_play

modified_view :: Update.UiUpdate -> Bool
modified_view :: UiUpdate -> Bool
modified_view (Update.View ViewId
_ View
update) = case View
update of
    Update.CreateView {} -> Bool
True
    Update.DestroyView {} -> Bool
True
    View
_ -> Bool
False
modified_view UiUpdate
_ = Bool
False