-- 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 ViewPatterns #-}
module Cmd.Msg where
import           Control.DeepSeq (deepseq)
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified System.IO as IO

import qualified Util.Log as Log
import qualified Util.Pretty as Pretty
import qualified App.ReplProtocol as ReplProtocol
import qualified Cmd.InputNote as InputNote
import qualified Cmd.KeyLayouts as KeyLayouts
import qualified Derive.Derive as Derive
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.TrackWarp as TrackWarp

import qualified Local.KeyLayout
import qualified Midi.Midi as Midi
import qualified Perform.Transport as Transport
import qualified Synth.ImGc as ImGc
import qualified Ui.Id as Id
import qualified Ui.Key as Key
import qualified Ui.Track as Track
import qualified Ui.Ui as Ui
import qualified Ui.UiMsg as UiMsg

import           Control.Monad
import           Global
import           Types


data Msg =
    -- | Message from the UI.
    Ui UiMsg.UiMsg
    -- | Incoming midi message.
    | Midi Midi.ReadMessage
    -- | Incoming abstract note.  This is meant to enter a note and is not
    -- a MIDI NoteOn, though NoteOns may very well be translated into these.
    -- These are not generated from any subsystem, but instead translated from
    -- other msgs (such as Midi).
    | InputNote InputNote.Input
    -- | Message from the transport/play thread.
    | Transport Transport.Status
    -- | Message about the derivation status, from the background derivation
    -- threads.
    | DeriveStatus BlockId DeriveStatus
    -- | Message from the REPL socket, includes the socket handle than can be
    -- used to write a response.  Whoever responds to it should close the
    -- handle.
    | Socket IO.Handle ReplProtocol.Query
    deriving (Int -> Msg -> ShowS
[Msg] -> ShowS
Msg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Msg] -> ShowS
$cshowList :: [Msg] -> ShowS
show :: Msg -> String
$cshow :: Msg -> String
showsPrec :: Int -> Msg -> ShowS
$cshowsPrec :: Int -> Msg -> ShowS
Show)

show_short :: Msg -> Text
show_short :: Msg -> Text
show_short = \case
    Ui UiMsg
ui -> UiMsg -> Text
UiMsg.show_short UiMsg
ui
    Midi ReadMessage
midi -> forall a. Pretty a => a -> Text
pretty ReadMessage
midi
    InputNote Input
note -> forall a. Pretty a => a -> Text
pretty Input
note
    Transport Status
status -> forall a. Pretty a => a -> Text
pretty Status
status
    -- show_short is used for timing, and Show DeriveStatus can force stuff in
    -- Performance, so let's avoid the Show instance.
    DeriveStatus BlockId
bid DeriveStatus
status -> forall a. Ident a => a -> Text
Id.ident_text BlockId
bid forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> case DeriveStatus
status of
        DeriveStatus
OutOfDate -> Text
"OutOfDate"
        DeriveStatus
Deriving -> Text
"Deriving"
        DeriveComplete {} -> Text
"DeriveComplete"
        status :: DeriveStatus
status@(ImStatus {}) -> forall a. Pretty a => a -> Text
pretty DeriveStatus
status
    Socket Handle
_hdl Query
query -> forall a. Pretty a => a -> Text
pretty Query
query

instance Pretty Msg where
    pretty :: Msg -> Text
pretty = \case
        Ui UiMsg
msg -> Text
"Ui: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty UiMsg
msg
        Midi ReadMessage
msg -> Text
"Midi: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ReadMessage
msg
        InputNote Input
msg -> Text
"Input: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Input
msg
        Transport Status
status -> forall a. Pretty a => a -> Text
pretty Status
status
        DeriveStatus BlockId
bid DeriveStatus
status -> Text
"DeriveStatus: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt BlockId
bid forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty DeriveStatus
status
        Socket Handle
_hdl Query
query -> Text
"Socket: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Query
query

data DeriveStatus =
    -- | The current derivation is out of date, but work has not yet started
    -- on a replacement.  The new Performance is already in
    -- 'Cmd.state_current_performance' but not in 'Cmd.state_performance' yet.
    OutOfDate
    | Deriving
    | DeriveComplete !Performance !ImStarted
    -- | The BlockId is the block to which this status applies, the BlockId
    -- in the containing DeriveStatus is the root block for the derivation.
    -- It's redundant for 'ImComplete', because only the root block gets one of
    -- those.
    | ImStatus !BlockId !(Set TrackId) !ImStatus
    deriving (Int -> DeriveStatus -> ShowS
[DeriveStatus] -> ShowS
DeriveStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeriveStatus] -> ShowS
$cshowList :: [DeriveStatus] -> ShowS
show :: DeriveStatus -> String
$cshow :: DeriveStatus -> String
showsPrec :: Int -> DeriveStatus -> ShowS
$cshowsPrec :: Int -> DeriveStatus -> ShowS
Show)

instance Pretty DeriveStatus where
    pretty :: DeriveStatus -> Text
pretty = \case
        ImStatus BlockId
block_id Set TrackId
track_ids ImStatus
status ->
            forall a. Pretty a => a -> Text
pretty BlockId
block_id forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Set TrackId
track_ids forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ImStatus
status
        DeriveStatus
status -> forall a. Show a => a -> Text
showt DeriveStatus
status

data ImStarted = ImStarted -- ^ im subprocess in progress
    | ImUnnecessary -- ^ no im notes, so no subprocesses started
    deriving (Int -> ImStarted -> ShowS
[ImStarted] -> ShowS
ImStarted -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImStarted] -> ShowS
$cshowList :: [ImStarted] -> ShowS
show :: ImStarted -> String
$cshow :: ImStarted -> String
showsPrec :: Int -> ImStarted -> ShowS
$cshowsPrec :: Int -> ImStarted -> ShowS
Show)

data ImStatus =
    -- | start--end currently being rendered.
    ImRenderingRange !ScoreT.Instrument !RealTime !RealTime
    -- | Waveforms written for these chunks.
    | ImWaveformsCompleted ![Track.WaveformChunk]
    -- | True if the im subprocess had a failure.  The error will have been
    -- logged, and this flag will leave a visual indicator on the track that
    -- something went wrong.
    | ImComplete !Bool !(Maybe ImGc.Stats)
    deriving (Int -> ImStatus -> ShowS
[ImStatus] -> ShowS
ImStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImStatus] -> ShowS
$cshowList :: [ImStatus] -> ShowS
show :: ImStatus -> String
$cshow :: ImStatus -> String
showsPrec :: Int -> ImStatus -> ShowS
$cshowsPrec :: Int -> ImStatus -> ShowS
Show)

instance Pretty ImStatus where
    pretty :: ImStatus -> Text
pretty = \case
        ImRenderingRange Instrument
inst RealTime
start RealTime
end ->
            forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
start forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
end forall a. Semigroup a => a -> a -> a
<> Text
")"
        ImWaveformsCompleted [WaveformChunk]
waves -> Text
"ImWaveformsCompleted:"
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," (forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaveformChunk -> String
Track._filename) [WaveformChunk]
waves)
        ImComplete Bool
failed Maybe Stats
_ -> Text
"ImComplete" forall a. Semigroup a => a -> a -> a
<> if Bool
failed then Text
"(failed)" else Text
""

-- Performance should be in "Cmd.Cmd", but that would be a circular import.

{- | This holds the final performance for a given block.  It is used to
    actually play music, and poked and prodded in a separate thread to control
    its evaluation.

    This is basically the same as 'Derive.Result'.  I could make them be the
    same, but Performance wasn't always the same and may not be the same in the
    future.

    Unlike other records, the fields here are all lazy.  This is because I need
    to put an unevaluated Performance into Cmd.state_current_performances, and
    then force the fields in a separate thread.  Also I need to modify
    'perf_damage' without forcing any of the others.
-}
data Performance = Performance {
    Performance -> Cache
perf_derive_cache :: Derive.Cache
    -- | This is the forced result of a derivation.
    , Performance -> Vector Event
perf_events :: Vector.Vector Score.Event
    -- | Logs from the derivation are written separately.
    , Performance -> [Msg]
perf_logs :: [Log.Msg]
    -- | The logs are only written on the first play, to minimize error spam.
    -- So there's a flag which says whether these logs have been written or
    -- not.  I don't clear the logs, so 'Cmd.Repl.LPerf.cache_stats' can
    -- inspect them.
    , Performance -> Bool
perf_logs_written :: Bool
    , Performance -> TrackDynamic
perf_track_dynamic :: Derive.TrackDynamic
    , Performance -> [Integrated]
perf_integrated :: [Derive.Integrated]
    -- | ScoreDamage is normally calculated automatically from the UI diff,
    -- but Cmds can also intentionally inflict damage to cause a rederive.
    , Performance -> ScoreDamage
perf_damage :: Derive.ScoreDamage
    , Performance -> [TrackWarp]
perf_warps :: [TrackWarp.TrackWarp]
    , Performance -> TrackSignals
perf_track_signals :: Track.TrackSignals
    , Performance -> BlockDeps
perf_block_deps :: Derive.BlockDeps
    -- | Map each track to the instruments on it.  This tries to remain lazy,
    -- since it's only used by muted_im_instruments.
    , Performance -> Map TrackId (Set Instrument)
perf_track_instruments :: Map TrackId (Set ScoreT.Instrument)
    -- | This is the score state at the time of the performance.  It's needed
    -- to interpret 'perf_track_signals', because at the time signals are sent
    -- (in 'Cmd.PlayC.cmd_play_msg'), the Ui.State may have unsynced changes.
    , Performance -> State
perf_ui_state :: Ui.State
    }

-- | Force a Performance so that it can be used without a lag.
force_performance :: Performance -> ()
force_performance :: Performance -> ()
force_performance (Performance Cache
_cache Vector Event
events [Msg]
logs Bool
_logs_written TrackDynamic
track_dyn
        [Integrated]
_integrated ScoreDamage
_damage [TrackWarp]
warps TrackSignals
track_sigs BlockDeps
block_deps Map TrackId (Set Instrument)
_track_insts State
ui_state) =
    [Msg]
logs forall a b. NFData a => a -> b -> b
`deepseq` Vector Event
events forall a b. NFData a => a -> b -> b
`deepseq` [TrackWarp]
warps forall a b. NFData a => a -> b -> b
`deepseq` TrackDynamic
track_dyn
        forall a b. NFData a => a -> b -> b
`deepseq` TrackSignals
track_sigs forall a b. NFData a => a -> b -> b
`deepseq` BlockDeps
block_deps forall a b. NFData a => a -> b -> b
`deepseq` State
ui_state
        forall a b. NFData a => a -> b -> b
`deepseq` ()

instance Show Performance where
    show :: Performance -> String
show Performance
perf = String
"((Performance " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a. Vector a -> Int
Vector.length (Performance -> Vector Event
perf_events Performance
perf))
        forall a. Semigroup a => a -> a -> a
<> String
" events " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length (Performance -> [Msg]
perf_logs Performance
perf)) forall a. Semigroup a => a -> a -> a
<> String
" logs))"
        -- Show events and logs.  This way there's a hint to look at logs if
        -- there are mysteriously no events.

instance Pretty Performance where
    format :: Performance -> Doc
format (Performance Cache
cache Vector Event
events [Msg]
logs Bool
logs_written TrackDynamic
track_dynamic
            [Integrated]
integrated ScoreDamage
damage [TrackWarp]
warps TrackSignals
track_signals BlockDeps
block_deps Map TrackId (Set Instrument)
track_insts
            State
_ui_state) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Performance"
        [ (Text
"cache", forall a. Pretty a => a -> Doc
Pretty.format forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ (\(Derive.Cache Map CacheKey Cached
c) -> Map CacheKey Cached
c) Cache
cache)
        , (Text
"events", forall a. Pretty a => a -> Doc
Pretty.format (forall a. Vector a -> Int
Vector.length Vector Event
events))
        , (Text
"logs", forall a. Pretty a => a -> Doc
Pretty.format [Msg]
logs)
        , (Text
"logs_written", forall a. Pretty a => a -> Doc
Pretty.format Bool
logs_written)
        , (Text
"track_dynamic", forall a. Pretty a => a -> Doc
Pretty.format TrackDynamic
track_dynamic)
        , (Text
"integrated", forall a. Pretty a => a -> Doc
Pretty.format [Integrated]
integrated)
        , (Text
"damage", forall a. Pretty a => a -> Doc
Pretty.format ScoreDamage
damage)
        , (Text
"warps", forall a. Pretty a => a -> Doc
Pretty.format [TrackWarp]
warps)
        , (Text
"track_signals", forall a. Pretty a => a -> Doc
Pretty.format TrackSignals
track_signals)
        , (Text
"block_deps", forall a. Pretty a => a -> Doc
Pretty.format BlockDeps
block_deps)
        , (Text
"track_instruments", forall a. Pretty a => a -> Doc
Pretty.format Map TrackId (Set Instrument)
track_insts)
        ]

-- * views

-- To reduce dependency on the exact structure of 'Msg', and to avoid long hard
-- to read cases, use the view functions here.  They can be conveniently used
-- with the ViewPatterns feature.

mouse :: Msg -> Maybe UiMsg.MouseEvent
mouse :: Msg -> Maybe MouseEvent
mouse (Ui (UiMsg.UiMsg Context
_ (UiMsg.MsgEvent (UiMsg.Mouse MouseEvent
mouse)))) =
    forall a. a -> Maybe a
Just MouseEvent
mouse
mouse Msg
_ = forall a. Maybe a
Nothing

mouse_down :: Msg -> Bool
mouse_down :: Msg -> Bool
mouse_down Msg
msg = case Msg -> Maybe MouseEvent
mouse Msg
msg of
    Just (UiMsg.MouseEvent { mouse_state :: MouseEvent -> MouseState
UiMsg.mouse_state = UiMsg.MouseDown Int
_ }) -> Bool
True
    Maybe MouseEvent
_ -> Bool
False

kbd :: Msg -> Maybe (UiMsg.KbdState, [Key.Modifier], Key.Key, Maybe Char)
kbd :: Msg -> Maybe (KbdState, [Modifier], Key, Maybe Char)
kbd (Ui (UiMsg.UiMsg Context
_ (UiMsg.MsgEvent (UiMsg.Kbd KbdState
state [Modifier]
mods Key
key Maybe Char
text)))) =
    forall a. a -> Maybe a
Just (KbdState
state, [Modifier]
mods, Key
key, Maybe Char
text)
kbd Msg
_ = forall a. Maybe a
Nothing

key :: Msg -> Maybe (UiMsg.KbdState, Key.Key)
key :: Msg -> Maybe (KbdState, Key)
key (Msg -> Maybe (KbdState, [Modifier], Key, Maybe Char)
kbd -> Just (KbdState
state, [Modifier]
_, Key
key, Maybe Char
_)) = forall a. a -> Maybe a
Just (KbdState
state, Key
key)
key Msg
_ = forall a. Maybe a
Nothing

key_down :: Msg -> Maybe Key.Key
key_down :: Msg -> Maybe Key
key_down (Msg -> Maybe (KbdState, Key)
key -> Just (KbdState
UiMsg.KeyDown, Key
k)) = forall a. a -> Maybe a
Just Key
k
key_down Msg
_ = forall a. Maybe a
Nothing

-- | The text that this keydown wants to enter, if any.
text :: Msg -> Maybe (Key.Key, Maybe Char)
text :: Msg -> Maybe (Key, Maybe Char)
text (Msg -> Maybe (KbdState, [Modifier], Key, Maybe Char)
kbd -> Just (KbdState
UiMsg.KeyDown, [Modifier]
_, Key
key, Maybe Char
text)) = forall a. a -> Maybe a
Just (Key
key, Maybe Char
text)
text Msg
_ = forall a. Maybe a
Nothing

key_mods :: Msg -> Maybe [Key.Modifier]
key_mods :: Msg -> Maybe [Modifier]
key_mods (Msg -> Maybe (KbdState, [Modifier], Key, Maybe Char)
kbd -> Just (KbdState
_, [Modifier]
mods, Key
_, Maybe Char
_)) = forall a. a -> Maybe a
Just [Modifier]
mods
key_mods Msg
_ = forall a. Maybe a
Nothing

-- | A key action by keycap.  This is different from 'text' because it should
-- be just the keycap, not taking shift or alt or anything into account.
keycap :: Msg -> Maybe (UiMsg.KbdState, Char)
keycap :: Msg -> Maybe (KbdState, Char)
keycap Msg
msg = case Msg -> Maybe (KbdState, Key)
key Msg
msg of
    Just (KbdState
state, Key.Char Char
c) -> forall a. a -> Maybe a
Just (KbdState
state, Char
c)
    Maybe (KbdState, Key)
_ -> forall a. Maybe a
Nothing

-- | This is like 'keycap', but it takes shift into account.  This is because
-- it's convenient to bind to a single Char including shifted, and not have to
-- pass around a ([Key.Modifier], Char) or (Bool, Char).
char :: Msg -> Maybe (UiMsg.KbdState, Char)
char :: Msg -> Maybe (KbdState, Char)
char (Msg -> Maybe (KbdState, [Modifier], Key, Maybe Char)
kbd -> Just (KbdState
state, [Modifier]
mods, Key.Char Char
c, Maybe Char
_))
    | Modifier
Key.Shift forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Modifier]
mods =
        (KbdState
state,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Layout -> Char -> Maybe Char
KeyLayouts.to_shifted Layout
Local.KeyLayout.layout Char
c
        -- I have to use the keylayout instead of 'text' because fltk doesn't
        -- give me text for KeyUps.
    | Bool
otherwise= forall a. a -> Maybe a
Just (KbdState
state, Char
c)
char Msg
_ = forall a. Maybe a
Nothing

char_down :: Msg -> Maybe Char
char_down :: Msg -> Maybe Char
char_down (Msg -> Maybe (KbdState, Char)
char -> Just (KbdState
UiMsg.KeyDown, Char
c)) = forall a. a -> Maybe a
Just Char
c
char_down Msg
_ = forall a. Maybe a
Nothing

midi :: Msg -> Maybe Midi.Message
midi :: Msg -> Maybe Message
midi (Midi (Midi.ReadMessage { rmsg_msg :: ReadMessage -> Message
Midi.rmsg_msg = Message
msg })) = forall a. a -> Maybe a
Just Message
msg
midi Msg
_ = forall a. Maybe a
Nothing

context :: Msg -> Maybe UiMsg.Context
context :: Msg -> Maybe Context
context (Ui (UiMsg.UiMsg Context
context Msg
_)) = forall a. a -> Maybe a
Just Context
context
context Msg
_ = forall a. Maybe a
Nothing

context_track :: Msg -> Maybe (TrackNum, UiMsg.Track)
context_track :: Msg -> Maybe (Int, Track)
context_track = Context -> Maybe (Int, Track)
UiMsg.ctx_track forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Msg -> Maybe Context
context

context_track_pos :: Msg -> Maybe (TrackNum, ScoreTime)
context_track_pos :: Msg -> Maybe (Int, ScoreTime)
context_track_pos Msg
msg = Msg -> Maybe (Int, Track)
context_track Msg
msg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int
tracknum, Track
t) -> case Track
t of
    UiMsg.Track ScoreTime
pos -> forall a. a -> Maybe a
Just (Int
tracknum, ScoreTime
pos)
    Track
_ -> forall a. Maybe a
Nothing