{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module ALSA where

import qualified Option
import qualified Time
-- import qualified Log

import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Time as ATime
import qualified Sound.ALSA.Sequencer.Connect as Connect
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Exception as AlsaExc

import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg
import qualified Sound.MIDI.ALSA as MIDI

import qualified System.IO as IO

import qualified Data.Sequence as Seq
import qualified Data.NonEmpty as NEList

import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Reader as MR
import Control.Monad.IO.Class ( liftIO )
import Control.Monad.Trans.Cont ( ContT(ContT), runContT, mapContT )
import Control.Monad ( (<=<) )
import Control.Applicative ( Applicative )
import Control.Functor.HT ( void )
import qualified Data.Foldable as Fold
import Data.Foldable ( Foldable, forM_, foldMap )
import Data.Monoid ( mappend )


data Sequencer mode =
   Sequencer {
      handle :: SndSeq.T mode,
      publicPort, privatePort :: Port.T,
      ports :: Seq.Seq Port.T,
      queue :: Queue.T,
      latencyNano  :: Time.Nanoseconds  Integer,
      latencyMicro :: Time.Microseconds Int
   }


privateAddress ::
   (SndSeq.OpenMode mode) =>
   Sequencer mode -> IO Addr.T
privateAddress sq = do
   c <- Client.getId (handle sq)

   return $
      Addr.Cons {
         Addr.client = c,
         Addr.port = privatePort sq
      }


type Time = Time.Nanoseconds Integer

realTime :: Time -> RealTime.T
realTime (Time.Time time) =
   RealTime.fromInteger time

realTimeStamp :: Time -> ATime.T
realTimeStamp =
   ATime.consAbs . ATime.Real . realTime


newtype Send a = Send (MR.ReaderT (Sequencer SndSeq.DuplexMode) IO a)
   deriving (Functor, Applicative, Monad)

runSend :: Sequencer SndSeq.DuplexMode -> Send a -> IO a
runSend sq (Send m) = do
   a <- MR.runReaderT m sq
   void $ Event.drainOutput (handle sq)
   return a


class Monad send => SendClass send where
   liftSend :: Send a -> send a

instance SendClass Send where
   liftSend = id

instance SendClass send => SendClass (MS.StateT s send) where
   liftSend = MT.lift . liftSend

makeSend ::
   SendClass send =>
   (Sequencer SndSeq.DuplexMode -> IO a) -> send a
makeSend act =
   liftSend $ Send $ MR.ReaderT act

askSeq ::
   SendClass send =>
   send (Sequencer SndSeq.DuplexMode)
askSeq = makeSend return


sendEvent :: SendClass send => Event.T -> send ()
sendEvent ev = makeSend $ \sq ->
   void $ Event.output (handle sq) ev

sendEventOnQueue :: SendClass send => Event.T -> send ()
sendEventOnQueue ev = do
   sq <- askSeq
   sendEvent $ ev { Event.queue = queue sq }

queueControl ::
   SendClass send =>
   Event.QueueEv -> Maybe Event.T -> send ()
queueControl cmd proto =
   makeSend $ \sq -> Queue.control (handle sq) (queue sq) cmd proto

startQueue :: SendClass send => send ()
startQueue = do
   -- Log.put "start queue"
   queueControl Event.QueueStart Nothing

stopQueue :: SendClass send => send ()
stopQueue = do
   -- Log.put "stop queue"
   mapM_ sendEvent =<< allNotesOff
   queueControl Event.QueueStop Nothing

stopQueueLater :: SendClass send => Time -> send Time
stopQueueLater t = do
   sq <- askSeq
   let targetTime = mappend t $ latencyNano sq
   -- Log.put $ "stop queue delayed from " ++ show t ++ " to " ++ show targetTime
   sendAllNotesOffLater targetTime
   pauseQueueLater targetTime
   return targetTime

pauseQueue ::SendClass send => send ()
pauseQueue = do
   -- Log.put "pause queue"
   queueControl Event.QueueStop Nothing

pauseQueueLater ::SendClass send => Time -> send ()
pauseQueueLater t = do
   -- Log.put "pause queue later"
   queueControl Event.QueueStop . Just =<< stampedQueueEvent t

continueQueue :: SendClass send => send ()
continueQueue = do
   -- Log.put "continue queue"
   queueControl Event.QueueContinue Nothing

sendAllNotesOffLater :: SendClass send => Time -> send ()
sendAllNotesOffLater t = do
   mapM_ (sendEvent <=< stamp t) =<< allNotesOff

stamp :: SendClass send => Time -> Event.T -> send Event.T
stamp t ev = do
   sq <- askSeq
   return $
       ev{Event.queue = queue sq,
          Event.time = realTimeStamp t}

stampedQueueEvent :: SendClass send => Time -> send Event.T
stampedQueueEvent t =
   stamp t $ Event.simple Addr.unknown $ Event.EmptyEv Event.None

allNotesOff :: SendClass send => send [Event.T]
allNotesOff =
   makeSend $ \sq -> return $ do
      port <- Fold.toList $ ports sq
      chan <- [minBound .. maxBound]
      return $
         Event.forSourcePort port $
         Event.CtrlEv Event.Controller $
         MIDI.modeEvent chan ModeMsg.AllNotesOff



forwardQueue :: SendClass send => Time -> send ()
forwardQueue t = do
   -- Log.put "forward queue"
   queueControl (Event.QueueSetPosTime (realTime t)) Nothing

forwardStoppedQueue :: SendClass send => Time -> send ()
forwardStoppedQueue t = do
   -- Log.put "forward stopped queue"
   {-
   This event is not scheduled,
   since it must work also if the queue is stopped.
   -}
   queueControl Event.QueueContinue Nothing
   queueControl (Event.QueueSetPosTime (realTime t)) Nothing
   {-
   This event is scheduled,
   because it must wait until after the AllNotesOff events.
   -}
   pauseQueueLater t

forwardContinueQueue :: SendClass send => Time -> send ()
forwardContinueQueue t = do
   -- Log.put "forward and continue queue"
   queueControl (Event.QueueSetPosTime (realTime t)) Nothing
   queueControl Event.QueueContinue Nothing


parseAndConnect ::
   (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
   SndSeq.T mode ->
   Option.Port -> ContT () IO Port.T
parseAndConnect h (Option.Port name from to) = do
   let caps =
          mappend
             (foldMap (const $ Port.caps [Port.capWrite, Port.capSubsWrite]) from)
             (foldMap (const $ Port.caps [Port.capRead,  Port.capSubsRead]) to)
   p <- ContT $
      Port.withSimple h name caps
         (Port.types [Port.typeMidiGeneric, Port.typeSoftware, 
                      Port.typeApplication])
   liftIO $ forM_ from $ mapM_ (Connect.createFrom h p <=< Addr.parse h)
   liftIO $ forM_ to   $ mapM_ (Connect.createTo   h p <=< Addr.parse h)
   return p


withSequencer ::
   (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
   Option.Option -> (Sequencer mode -> IO ()) -> IO ()
withSequencer opt@(Option.Option { Option.connect = NEList.Cons firstPort otherPorts } ) =
   runContT $
   mapContT (flip AlsaExc.catch
      (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e)) $ do
   h <- ContT $ SndSeq.with SndSeq.defaultName SndSeq.Block
   liftIO $ Client.setName h $ Option.sequencerName opt
   public <- parseAndConnect h firstPort
   ps <-
      fmap ((public Seq.<|) . Seq.fromList) $
      mapM (parseAndConnect h) otherPorts
   private <- ContT $
      Port.withSimple h "echo"
         (Port.caps [Port.capRead, Port.capWrite])
         (Port.types [Port.typeSpecific])
   q <- ContT $ Queue.with h
   return $
      Sequencer {
          handle = h,
          publicPort = public,
          privatePort = private,
          ports = ps,
          queue = q,
          latencyNano = fmap round $ Time.seconds (Option.latency opt),
          latencyMicro = fmap round $ Time.seconds (Option.latency opt)
      }