module Event where

import Term ( Term(Number, StringLiteral), termRange )
import ALSA ( Sequencer(handle, queue, privatePort), sendEvent )
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.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Client as Client
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 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.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 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 Data.Maybe ( isJust )

import Control.Concurrent.Chan ( Chan, readChan, writeChan )
import Control.Concurrent ( forkIO )



type Time = Time.Nanoseconds Integer

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

data WaitResult =
         ModeChange WaitMode | ReachedTime SeqEvent.TimeStamp | NextStep
    deriving (Show)


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


play ::
    (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
    Sequencer mode ->
    (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
            (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 ::
    (SndSeq.AllowOutput mode) =>
    Sequencer mode ->
    (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)
    case Term.viewNode body of
        Just ("On", [pn, vn]) -> do
            p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn
            v <- checkVelocity vn
            runIO $ sendNote sq SeqEvent.NoteOn chanPort p v
        Just ("Off", [pn, vn]) -> do
            p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn
            v <- checkVelocity vn
            runIO $ sendNote sq SeqEvent.NoteOff chanPort p v
        Just ("PgmChange", [pn]) -> do
            p <- checkRangeAuto "program" CM.toProgram CM.fromProgram pn
            runIO $
                sendEvent sq 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
            runIO $
                sendEvent sq port $ SeqEvent.CtrlEv SeqEvent.Controller $
                MidiAlsa.controllerEvent chan cc (fromIntegral v)
        _ -> termException body "invalid channel event: "
    return Nothing


wait ::
    (SndSeq.AllowOutput mode) =>
    Sequencer mode ->
    Chan WaitResult ->
    Maybe Time ->
    MS.StateT State IO ()
wait sq waitChan mdur = do
    let loop target = do
           liftIO $ Log.put $ "readChan waitChan"
           ev <- liftIO $ readChan 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) <- prepare sq mdur
                         when cont $ loop newTarget
                     else loop target
               ReachedTime stamp ->
                   case stamp of
                       SeqEvent.RealTime rt ->
                           let reached =
                                   Time.nanoseconds $ RealTime.toInteger rt
                           in  if Just reached == target
                                 then AccM.set stateTime reached
                                 else loop target
                       _ -> loop target
               NextStep ->
                   when (isJust target) $ loop target

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


prepare ::
    (SndSeq.AllowOutput mode) =>
    Sequencer mode -> Maybe Time ->
    MS.StateT State IO (Bool, Maybe Time)
prepare sq mt = do
    liftIO $ Log.put $ "prepare waiting for " ++ show mt
    (State waitMode _ currentTime _) <- MS.get
    case waitMode of
        RealTime -> do
            case mt of
                Nothing -> return (False, Nothing)
                Just dur -> do
                    let t = mappend currentTime dur
                    sendEcho sq t
                    return (True, Just t)
        SlowMotion dur -> do
            let t = mappend currentTime $ Time.up $ Time.up dur
            sendEcho sq t
            return (True, Just t)
        SingleStep ->
            return (True, Nothing)


sendEcho ::
    (MonadIO io, SndSeq.AllowOutput mode) =>
    Sequencer mode -> Time ->
    io ()
sendEcho sq (Time.Time t) = do
    c <- liftIO $ Client.getId (handle sq)

    {-
    liftIO $ Log.put . ("wait, send echo for " ++) . show =<< MS.get
    -}
    let dest =
            Addr.Cons {
               Addr.client = c,
               Addr.port = privatePort sq
            }

    liftIO $ Log.put $ "send echo message to " ++ show dest
    liftIO $ void $ SeqEvent.output (handle sq) $
       (SeqEvent.simple
          (Addr.Cons c Port.unknown)
          (SeqEvent.CustomEv SeqEvent.Echo (SeqEvent.Custom 0 0 0)))
          { SeqEvent.queue = queue sq
          , SeqEvent.timestamp =
                SeqEvent.RealTime $ RealTime.fromInteger t
          , SeqEvent.dest = dest
          }

    liftIO $ void $ SeqEvent.drainOutput (handle sq)


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

    let dest =
            Addr.Cons {
               Addr.client = c,
               Addr.port = privatePort sq
            }

    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 ->
                noteInput $ note ^. MidiAlsa.notePitch
            SeqEvent.CustomEv SeqEvent.Echo _ ->
                when (dest == SeqEvent.dest ev) $ do
                    Log.put "write waitChan"
                    writeChan waitChan $ ReachedTime $ SeqEvent.timestamp ev
            _ -> return ()


sendNote ::
    (SndSeq.AllowOutput mode) =>
    Sequencer mode ->
    SeqEvent.NoteEv ->
    (Port.T, CM.Channel) ->
    CM.Pitch ->
    CM.Velocity ->
    IO ()
sendNote sq onoff (port,chan) pitch velocity =
    sendEvent sq port $
    SeqEvent.NoteEv onoff $ MidiAlsa.noteEvent chan pitch velocity velocity 0