{- |
The tricky part of the event scheduling is how to achieve precise timing.

We want to achieve:

* Precisely timed sending of MIDI events.

* Immediate start of music when you start the interpreter.

* Immediate stop of music when you stop the interpreter.

We achieve precise timing by sending the events with a fixed delay
that the user can set with the 'latency' command line option.
That is, if latency is 0.1s,
then we tell ALSA at time point t to send an event at t+0.1s.
This way we make ALSA responsible for precise timing,
and it actually makes a good job.
In order to prevent cumulation of rounding errors
we maintain the ideal time in the 'stateTime' field of our 'State' record.
This time should always be a little bit smaller than the time in the ALSA queue.

In total, for every element in the MIDI stream we send two ALSA events:

* If the current event is @Wait@ and we are in real-time mode,
  then we send an Echo event with evaluateId to ourselves
  with a delay according to the @Wait@ value.

* If the current event is @Event@,
  then we send the according MIDI event via ALSA with a delay of latency
  with respect to the current ideal time.

* In any case we send a delayed Echo event with visualizeId to ourselves.
  This Echo makes sure that the display is updated
  when ALSA ships the event and
  not immediately after the computation of the event.

The 'wait' function is responsible for waiting between events
depending on the execution mode.
Actually, the essence of execution modes is how we wait.
In real-time mode it waits according to @Wait@ events.
In slow-motion mode it waits a fixed duration between events.
In single-step mode it waits for @Next step@ user commands.
The function also reacts to execution mode changes within a waiting period.
Actually, changes to execution mode can only happen during waiting.

The very tricky part is how to react immediately
to start and stop of the interpreter.
Of course, if the user requests interpreter start
we cannot send an event immediately
because we have to compute one first.
However, we pretend that the first event is sent immediately
and send following events according to the ideal start time.
The interpreter has to compute many events at once
until it is @latency@ ahead of the current ALSA queue time.
If the interpreter is paused
then events for the duration of @latency@ will remain in the queue.
If the user switches back from pause to realtime execution
then the stored events shall be shipped regularly.
However, if the user requests the next step in single step mode,
then these events must be shipped at once,
since we do not want to simply drop them.
If we would drop them we would risk hanging tones.
We achieve the shipping at once
by moving the ALSA queue time by @latency@ forward.

We use the trick of increasing the ALSA queue time at several places.
We use it whenever it is necessary to react immediately to a user request.
In order to avoid adding up multiple latencies
we always add the latency to the ideal time,
not to the current ALSA queue time.
We also have to take care of order of ALSA MIDI events.
Although stopping the interpreter
shall immediately send an AllNotesOff,
we must schedule the AllNotesOff event with a latency
and increment ALSA queue time
in order to assert correct ordering with previous and following MIDI events.
In contrast to that we must send some Queue control commands
like QueueContinue immediately,
because the queue might be stopped and
in this state scheduled events may not be processed.
-}
module Event where

import Term ( Term(Number, StringLiteral), termRange )
import ALSA ( Sequencer(handle), Time )
import qualified Term
import qualified ALSA
import qualified Time
import qualified Exception
import qualified Log

import qualified Sound.MIDI.Message.Channel as CM
import qualified Sound.MIDI.Message.Channel.Voice as VM
import qualified Sound.MIDI.ALSA as MidiAlsa
import qualified Sound.MIDI.MachineControl as MMC

import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Time as ATime
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Event as SeqEvent
import qualified Sound.ALSA.Sequencer as SndSeq

import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Exception.Asynchronous as ExcA
import Control.Monad.Exception.Synchronous ( ExceptionalT, throwT )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad ( when, forever )
import Control.Functor.HT ( void )
import Data.Foldable ( forM_ )

import Data.Monoid ( mempty, mappend )

import qualified System.Process as Proc
import qualified System.Exit as Exit
import qualified System.IO.Strict as StrictIO
import qualified System.IO as IO
import Data.IORef ( newIORef, readIORef, modifyIORef )

import qualified Data.Accessor.Monad.Trans.State as AccM
import qualified Data.Accessor.Basic as Acc
import Data.Accessor.Basic ((^.), )

import qualified Data.Sequence as Seq
import qualified Data.ByteString as B
import Data.Maybe ( isJust )
import Data.Bool.HT ( if' )

import qualified Control.Concurrent.Split.Chan as Chan
import Control.Concurrent ( forkIO )


data WaitMode =
         RealTime | SlowMotion (Time.Milliseconds Integer) | SingleStep Continue
    deriving (Eq, Show)

data WaitResult =
         ModeChange WaitMode | SwitchMode (WaitMode -> IO ()) |
         ReachedTime Time | NextStep Continue |
         AlsaSend (MS.StateT State ALSA.Send ())

data Continue =
         NextElement | NextReduction | NextReductionShow
    deriving (Eq, Show)


singleStep :: WaitMode
singleStep = SingleStep NextElement


termException ::
    (Monad m) =>
    Term -> String -> ExceptionalT Exception.Message m a
termException s msg =
    throwT $
    Exception.Message Exception.Term
        (termRange s) (msg ++ " " ++ show s)


runIO :: (MonadIO m) => IO a -> ExceptionalT Exception.Message m a
runIO action = MT.lift $ liftIO action


checkRange ::
    (Bounded a, Monad m) =>
    String -> (Int -> a) -> (a -> Int) ->
    a -> a ->
    Term ->
    ExceptionalT Exception.Message m a
checkRange typ fromInt toInt minb maxb =
    Exception.lift .
    Exception.checkRange Exception.Term typ fromInt toInt minb maxb

checkRangeAuto ::
    (Bounded a, Monad m) =>
    String -> (Int -> a) -> (a -> Int) ->
    Term ->
    ExceptionalT Exception.Message m a
checkRangeAuto typ fromInt0 toInt0 =
    Exception.lift .
    Exception.checkRangeAuto Exception.Term typ fromInt0 toInt0


data State =
    State {
        stateWaitMode_ :: WaitMode,
        stateWaiting_ :: Bool,
        stateTime_ :: Time,
        stateRecentTimes_ :: Seq.Seq Time
    }

stateWaitMode :: Acc.T State WaitMode
stateWaitMode = Acc.fromSetGet (\x s -> s{stateWaitMode_ = x}) stateWaitMode_

stateWaiting :: Acc.T State Bool
stateWaiting = Acc.fromSetGet (\x s -> s{stateWaiting_ = x}) stateWaiting_

stateTime :: Acc.T State Time
stateTime = Acc.fromSetGet (\x s -> s{stateTime_ = x}) stateTime_

stateRecentTimes :: Acc.T State (Seq.Seq Time)
stateRecentTimes = Acc.fromSetGet (\x s -> s{stateRecentTimes_ = x}) stateRecentTimes_

initState :: State
initState = State Event.RealTime False mempty Seq.empty

runState :: (Monad m) => MS.StateT State m a -> m a
runState = flip MS.evalStateT Event.initState


runSend ::
    Sequencer SndSeq.DuplexMode ->
    MS.StateT s ALSA.Send a ->
    MS.StateT s IO a
runSend sq = MS.mapStateT (ALSA.runSend sq)


play ::
    Sequencer SndSeq.DuplexMode ->
    (Exception.Message -> IO ()) ->
    Term ->
    ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time)
play sq throwAsync x = case Term.viewNode x of
    Just ("Wait", [Number _ n]) -> do
        when (n<0) $ termException x $
            "pause of negative duration: " ++ show n
        MT.lift $ AccM.set stateWaiting True
        return $ Just $ Time.milliseconds n

    Just ( "Say", [StringLiteral rng arg] ) ->
            MT.lift $ (AccM.set stateWaiting False >>) $ liftIO $ do
        let cmd = unwords
                      [ "echo", show arg, "|", "festival", "--tts" ]
        Log.put cmd
        void $ forkIO $ do
            Time.pause $ ALSA.latencyMicro sq
            (inp,_out,err,pid) <-
                Proc.runInteractiveProcess
                    "festival" [ "--tts" ] Nothing Nothing
            void $ forkIO (IO.hPutStr inp arg >> IO.hClose inp)
            errText <- StrictIO.hGetContents err
            exitCode <- Proc.waitForProcess pid
            case exitCode of
                Exit.ExitSuccess ->
                    when (not (null errText)) $
                    throwAsync $
                    Exception.Message Exception.Term rng ("warning: " ++ errText)
                Exit.ExitFailure _ ->
                    throwAsync $
                    Exception.Message Exception.Term rng errText

        return Nothing

    Just ("Event", [event]) -> case Term.viewNode event of
        Just ("Channel", [chann, body]) -> do
            chan <-
                checkRange "channel" id id
                    0 (Seq.length (ALSA.ports sq) * 16 - 1) chann
            let (p, c) = divMod chan 16
            processChannelMsg sq (Seq.index (ALSA.ports sq) p, CM.toChannel c) body
        _ -> processChannelMsg sq (ALSA.publicPort sq, CM.toChannel 0) event
           -- termException x "Event must contain Channel, but not "
    _ -> termException x "can only process Wait or Event, but not "

processChannelMsg ::
    Sequencer SndSeq.DuplexMode ->
    (Port.T, CM.Channel) -> Term ->
    ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time)
processChannelMsg sq chanPort@(port, chan) body = do
    MT.lift $ AccM.set stateWaiting False
    let checkVelocity =
            checkRange "velocity" CM.toVelocity CM.fromVelocity
                (CM.toVelocity 1) (CM.toVelocity 127)
        runSendE = MT.lift . runSend sq
    case Term.viewNode body of
        Just ("On", [pn, vn]) -> do
            p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn
            v <- checkVelocity vn
            runSendE $ sendNote SeqEvent.NoteOn chanPort p v
        Just ("Off", [pn, vn]) -> do
            p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn
            v <- checkVelocity vn
            runSendE $ sendNote SeqEvent.NoteOff chanPort p v
        Just ("PgmChange", [pn]) -> do
            p <- checkRangeAuto "program" CM.toProgram CM.fromProgram pn
            runSendE $
                sendEvent port $ SeqEvent.CtrlEv SeqEvent.PgmChange $
                MidiAlsa.programChangeEvent chan p
        Just ("Controller", [ccn, vn]) -> do
            cc <- checkRangeAuto "controller" CM.toController CM.fromController ccn
            v <- checkRange "controller value" id id 0 127 vn
            runSendE $
                sendEvent port $ SeqEvent.CtrlEv SeqEvent.Controller $
                MidiAlsa.controllerEvent chan cc (fromIntegral v)
        _ -> termException body "invalid channel event: "
    return Nothing


wait ::
    Sequencer SndSeq.DuplexMode ->
    Chan.Out WaitResult ->
    Maybe Time ->
    MS.StateT State IO ()
wait sq waitChan mdur = do
    let loop target = do
           liftIO $ Log.put $ "Chan.read waitChan"
           ev <- liftIO $ Chan.read waitChan
           -- liftIO $ Log.put $ "read from waitChan: " ++ show ev
           case ev of
               ModeChange newMode -> do
                   oldMode <- AccM.get stateWaitMode
                   if newMode /= oldMode
                     then do
                         AccM.set stateWaitMode newMode
                         (cont,newTarget) <- runSend sq $ prepare mdur
                         when cont $ loop newTarget
                     else loop target
               SwitchMode update -> do
                   oldMode <- AccM.get stateWaitMode
                   liftIO $ update $
                       case oldMode of
                           SingleStep _ -> RealTime
                           _ -> SingleStep NextElement
                   loop target
               ReachedTime reached ->
                   {- check for equality only works
                      because we have not set TimeStamping -}
                   if Just reached == target
                     then AccM.set stateTime reached
                     else loop target
               NextStep cont -> do
                   AccM.set stateWaitMode $ SingleStep cont
                   runSend sq forwardStoppedQueue
                   when (isJust target) $ loop target
               AlsaSend send -> do
                   runSend sq send
                   loop target

    (cont,targetTime) <- runSend sq $ prepare mdur
    when cont $ loop targetTime


forwardStoppedQueue ::
    MS.StateT State ALSA.Send ()
forwardStoppedQueue = do
    sq <- ALSA.askSeq
    t <- fmap (mappend (ALSA.latencyNano sq)) $ AccM.get stateTime
    ALSA.forwardStoppedQueue t

forwardQuietContinueQueue ::
    MS.StateT State ALSA.Send ()
forwardQuietContinueQueue = do
    sq <- ALSA.askSeq
    t <- fmap (mappend (ALSA.latencyNano sq)) $ AccM.get stateTime
    ALSA.sendAllNotesOffLater t
    ALSA.forwardContinueQueue t

forwardStopQueue ::
    MS.StateT State ALSA.Send ()
forwardStopQueue = do
    sq <- ALSA.askSeq
    t <- fmap (mappend (ALSA.latencyNano sq)) $ AccM.get stateTime
    ALSA.sendAllNotesOffLater t
    ALSA.forwardStoppedQueue t


prepare ::
    Maybe Time ->
    MS.StateT State ALSA.Send (Bool, Maybe Time)
prepare mdur = do
    -- liftIO $ Log.put $ "prepare waiting for " ++ show mdur
    waitMode <- AccM.get stateWaitMode
    let sendEchoCont d = do
            t <- sendEcho evaluateId d
            return (True, Just t)
    case waitMode of
        RealTime -> do
            case mdur of
                Nothing -> return (False, Nothing)
                Just dur -> sendEchoCont dur
        SlowMotion dur -> sendEchoCont $ Time.up $ Time.up dur
        SingleStep _ -> return (True, Nothing)


newtype EchoId = EchoId SeqEvent.Tag
    deriving (Eq, Show)

evaluateId, visualizeId :: EchoId
evaluateId  = EchoId (SeqEvent.Tag 0)
visualizeId = EchoId (SeqEvent.Tag 1)


sendEcho ::
    EchoId -> Time ->
    MS.StateT State ALSA.Send Time
sendEcho (EchoId echoId) dur = do
    {-
    liftIO $ Log.put . ("wait, send echo for " ++) . show =<< MS.get
    -}
    dest <- ALSA.makeSend ALSA.privateAddress

    currentTime <- AccM.get stateTime
    let targetTime = mappend currentTime dur

    -- liftIO $ Log.put $ "send echo message to " ++ show dest
    ALSA.sendEventOnQueue $
        (SeqEvent.simple dest
            (SeqEvent.CustomEv SeqEvent.Echo
                (SeqEvent.customZero)))
           { SeqEvent.tag = echoId,
             SeqEvent.dest = dest,
             SeqEvent.time =
                 ALSA.realTimeStamp targetTime
           }

    return targetTime


data Command =
      NoteInput VM.Pitch
    | Transportation Transportation
    deriving (Show)

data Transportation =
      Play
    | Stop
    | Pause
    | Forward
    deriving (Show)

{-
We cannot concurrently wait for different kinds of ALSA sequencer events.
Thus we run one thread that listens to all incoming ALSA sequencer events
and distributes them to who they might concern.
-}
listen ::
    (SndSeq.AllowInput mode) =>
    Sequencer mode ->
    (Command -> IO ()) ->
    IO () ->
    Chan.In WaitResult -> IO ()
listen sq noteInput visualize waitChan = do
    Log.put "listen to ALSA port"

    dest <- ALSA.privateAddress sq
    recording <- newIORef True

    forever $ do
        Log.put "wait, wait for echo"
        ev <- SeqEvent.input (handle sq)
        Log.put $ "wait, get message " ++ show ev
        case SeqEvent.body ev of
            SeqEvent.NoteEv SeqEvent.NoteOn note ->
                readIORef recording
                    >>= flip when (noteInput $ NoteInput $ note ^. MidiAlsa.notePitch)
            SeqEvent.ExtEv SeqEvent.SysEx msg ->
                {- FIXME: How to cope with the device id? -}
                case B.unpack msg of
                    0xF0 : 0x7F : 0x00 : 0x06 : cmds ->
                        forM_ (ExcA.result $ fst $
                               MMC.runParser MMC.getCommands cmds) $ \cmd ->
                            case cmd of
                                MMC.RecordStrobe -> modifyIORef recording not
                                MMC.Play -> noteInput $ Transportation Play
                                MMC.Stop -> noteInput $ Transportation Stop
                                MMC.Pause -> noteInput $ Transportation Pause
                                MMC.FastForward -> noteInput $ Transportation Forward
                                _ -> return ()
                    _ -> return ()
            SeqEvent.CustomEv SeqEvent.Echo _cust ->
                when (dest == SeqEvent.dest ev) $
                    if' (EchoId (SeqEvent.tag ev) == evaluateId)
                        (case SeqEvent.time ev of
                            ATime.Cons ATime.Absolute (ATime.Real rt) -> do
                                Log.put "write waitChan"
                                Chan.write waitChan $ ReachedTime $ 
                                    Time.nanoseconds $ RealTime.toInteger rt
                            _ -> return ())
                        (do
                            Log.put "visualize"
                            visualize)
            _ -> return ()


sendNote ::
    SeqEvent.NoteEv ->
    (Port.T, CM.Channel) ->
    CM.Pitch ->
    CM.Velocity ->
    MS.StateT State ALSA.Send ()
sendNote onoff (port,chan) pitch velocity =
    sendEvent port $ SeqEvent.NoteEv onoff $
    MidiAlsa.noteEvent chan pitch velocity velocity 0

sendEvent ::
    Port.T -> SeqEvent.Data ->
    MS.StateT State ALSA.Send ()
sendEvent p ev = do
    sq <- ALSA.askSeq
    currentTime <- AccM.get stateTime
    ALSA.sendEventOnQueue $
        (SeqEvent.forSourcePort p ev) {
            SeqEvent.time =
                ALSA.realTimeStamp $
                mappend currentTime $ ALSA.latencyNano sq
        }