module Sound.ALSA.Sequencer (
     createClient,
     deleteClient,
     createInputPort,
     createOutputPort,
     withEvents,
     receiveEvent,

     sendPlainEvent,
     drainOutput,

     initQueueTempo,
     withNamedQueue,

     portAddress,
     numAddress,
     numAddressEither,
     -- constructors only for internal use
     Client(sequencerHandle),
     SndSeq.Port(..),

     eventToChannelMsg,
     eventFromChannelMsg,
     eventFromMetaEvent,
  ) where

import qualified Sound.ALSA.Sequencer.FFI as SndSeq

import qualified Sound.MIDI.File.Event.Meta as MetaEvent
import qualified Sound.MIDI.Message.Channel       as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel.Mode  as ModeMsg

import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (with)
import Foreign.Storable (peek)
-- import Foreign.Ptr (Ptr)
import Foreign.C.String (withCString)
-- import Foreign.C.Types (CInt)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)

import Control.Exception (bracket)

import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Monad (liftM, liftM2)
import Data.Maybe (catMaybes)
import Data.Ix (inRange)


clientId :: Client -> SndSeq.ClientId
clientId = SndSeq.client_id . sequencerHandle

data Client = Client {
    sequencerHandle :: SndSeq.T,
    ports :: IORef [SndSeq.Port]
  }

portAddress :: Client -> SndSeq.Port -> SndSeq.Address
portAddress = SndSeq.Address . clientId

numAddress :: Integer -> Integer -> SndSeq.Address
numAddress client port =
   either error id $ numAddressEither client port

numAddressEither :: Integer -> Integer -> Either String SndSeq.Address
numAddressEither client port =
   if inRange (128,191) client
     then
       if inRange (0,255) port
         then Right
                 (SndSeq.Address
                     (SndSeq.ClientId $ fromInteger client)
                     (SndSeq.Port $ fromInteger port))
         else Left "port must be in range [0,255]"
     else Left "client must be in range [128,191]"


-- * Useful things

{- |
Process MIDI events from ALSA in a lazy manner.
The processing function must be strict,
in order to let the cleanup take place after abandoning the process.
-}
withEvents :: String -> String -> ([SndSeq.Event] -> IO a) -> IO a
withEvents clientName portName act = do
   bracket
      (createClient SndSeq.openInput clientName)
      deleteClient $
      \ client -> do
         -- Why is it necessary to use a writable port for reading events?
         createOutputPort client portName
         (act . catMaybes) =<< ioToLazyList (receiveEvent client)

deleteClient :: Client -> IO ()
deleteClient ac = do
    mapM_ (deletePort ac) =<< readIORef (ports ac)
    SndSeq.close (sequencerHandle ac)
    return ()

{-
event_input tells whether more events are waiting.
Maybe we should return a list of all events rather than a Maybe.
-}
receiveEvent :: Client -> IO (Maybe SndSeq.Event)
receiveEvent ac =
    alloca $ \eventPtrPtr ->
{- sometimes returns code -4 (Interrupted system call)
       SndSeq.check "receiveEvent" (SndSeq.event_input (sequencerHandle ac) eventPtrPtr)
         >> liftM eventToEvent (peek =<< peek eventPtrPtr)
-}
       SndSeq.event_input (sequencerHandle ac) eventPtrPtr
         >>= \(SndSeq.ReturnCode err) ->
            if err < 0
              then return Nothing
                -- fail "SndSeq.event_input failed"
              else liftM Just $ peek =<< peek eventPtrPtr

{- |
This function checks whether the ALSA sequencer message
is a MIDI channel message and converts to the corresponding data structure.

Note that ALSA sequencer events contain MIDI realtime messages,
MIDI file events and additional events.
We do not want to define yet another data structure
additionally to 'SndSeq.Event' and the message types from the midi package.
Instead, because we believe,
that most of the time you cope with certain types of events in bundles,
we provide functions that allow easy access to these types.
Currently we provide only access to MIDI channel messages
but that can be easily extended.
Multiple handlers of certain event types can be composed using 'Control.Monad.mplus'.

NoteOn events with zero velocity are not automatically converted to NoteOff events,
this can be done with the 'Sound.MIDI.Message.Channel.Voice.explicitNoteOff' function.
-}
eventToChannelMsg :: SndSeq.Event -> Maybe ChannelMsg.T
eventToChannelMsg ev =
   case SndSeq.eventData ev of
      SndSeq.Note
          {SndSeq.noteVelocity = v0,
           SndSeq.notePitch = p0,
           SndSeq.noteChannel = c0} ->
         let p = VoiceMsg.toPitch     $ fromIntegral p0
             v = VoiceMsg.toVelocity  $ fromIntegral v0
             c = ChannelMsg.toChannel $ fromIntegral c0
             cons = Just . ChannelMsg.Cons c . ChannelMsg.Voice
         in  case SndSeq.typ ev of
                SndSeq.EventNoteOn  ->
                   cons $
                   if v0==0
                     then VoiceMsg.NoteOff p (VoiceMsg.toVelocity 64)
                     else VoiceMsg.NoteOn  p v
                SndSeq.EventNoteOff ->
                   cons $ VoiceMsg.NoteOff p v
                SndSeq.EventKeyPressure ->
                   cons $ VoiceMsg.PolyAftertouch p $ fromIntegral v0
                _ -> fail ("eventToChannelMsg: note typ " ++ show ev)
      SndSeq.Control
          {SndSeq.controlChannel = c,
           SndSeq.controlParameter = p,
           SndSeq.controlValue = x} ->
         let cons = Just . ChannelMsg.Cons (ChannelMsg.toChannel $ fromIntegral c)
         in  case SndSeq.typ ev of
                SndSeq.EventController ->
                   cons $
                      if p<078
                        then ChannelMsg.Voice $ VoiceMsg.Control
                                (toEnum $ fromIntegral p)
                                (fromIntegral x)
                        else ChannelMsg.Mode $ snd $
                             ModeMsg.fromControllerValue (p, fromIntegral x)
                SndSeq.EventProgramChange ->
                   cons $ ChannelMsg.Voice $ VoiceMsg.ProgramChange
                      (VoiceMsg.toProgram $ fromIntegral x)
                SndSeq.EventChannelPressure ->
                   cons $ ChannelMsg.Voice $ VoiceMsg.MonoAftertouch (fromIntegral x)
                SndSeq.EventPitchBend ->
                   cons $ ChannelMsg.Voice $ VoiceMsg.PitchBend (fromIntegral x)
                _ -> fail ("eventToChannelMsg: cannot convert controller message " ++ show ev)
      _ -> Nothing

ioToLazyList :: IO a -> IO [a]
ioToLazyList m =
    unsafeInterleaveIO $
       liftM2 (:) m (ioToLazyList m)


mkNote ::
   ChannelMsg.Channel ->
   VoiceMsg.Pitch ->
   VoiceMsg.Velocity ->
   SndSeq.EventDataUnion
mkNote c p v =
   let v1 = fromIntegral $ VoiceMsg.fromVelocity v
   in  SndSeq.Note {
          SndSeq.noteChannel = fromIntegral $ ChannelMsg.fromChannel c,
          SndSeq.notePitch   = fromIntegral $ VoiceMsg.fromPitch p,
          SndSeq.noteVelocity = v1,
          SndSeq.noteOffVelocity = v1,
          SndSeq.noteDuration = 0}

mkControl ::
   ChannelMsg.Channel ->
   Int -> Int ->
--    CUInt -> CInt ->
   SndSeq.EventDataUnion
mkControl c p x =
   SndSeq.Control {
      SndSeq.controlChannel   = fromIntegral $ ChannelMsg.fromChannel c,
      SndSeq.controlParameter = fromIntegral p,
      SndSeq.controlValue     = fromIntegral x
   }

eventFromChannelMsg ::
   ChannelMsg.T -> (SndSeq.EventType, SndSeq.EventDataUnion)
eventFromChannelMsg (ChannelMsg.Cons c ev) =
   case ev of
      ChannelMsg.Voice voice ->
         case voice of
            VoiceMsg.NoteOn  p v -> (SndSeq.EventNoteOn,  mkNote c p v)
            VoiceMsg.NoteOff p v -> (SndSeq.EventNoteOff, mkNote c p v)
            VoiceMsg.Control ctrl x -> (SndSeq.EventController,
               mkControl c (VoiceMsg.fromController ctrl) x)
            VoiceMsg.ProgramChange p -> (SndSeq.EventProgramChange,
               mkControl c 0 (VoiceMsg.fromProgram p))
            VoiceMsg.MonoAftertouch x -> (SndSeq.EventChannelPressure,
               mkControl c 0 x)
            VoiceMsg.PolyAftertouch p x -> (SndSeq.EventKeyPressure,
               mkNote c p (VoiceMsg.toVelocity x))
            VoiceMsg.PitchBend x -> (SndSeq.EventPitchBend,
               mkControl c 0 x)
      ChannelMsg.Mode mode ->
         (SndSeq.EventController,
            let (ctrl, x) = ModeMsg.toControllerValue mode
            in  SndSeq.Control {
                   SndSeq.controlChannel = fromIntegral $ ChannelMsg.fromChannel c,
                   SndSeq.controlValue   = fromIntegral x,
                   SndSeq.controlParameter = ctrl
                })


eventFromMetaEvent ::
   SndSeq.Queue -> MetaEvent.T -> (SndSeq.EventType, SndSeq.EventDataUnion)
eventFromMetaEvent q ev =
   case ev of
      MetaEvent.SetTempo t -> (SndSeq.EventTempo, SndSeq.QueueEv {
          SndSeq.queueId = q,
          SndSeq.queueControl = SndSeq.QueueControlValue $ fromIntegral t})
      _ -> error ("eventFromMetaEvent: event type not yet implemented, " ++ show ev)



sendPlainEvent :: Client -> SndSeq.Event -> IO ()
sendPlainEvent client ev =
   with ev $ \evPtr ->
      liftM (const ()) $
      SndSeq.check "sendPlainEvent" $
      SndSeq.event_output (sequencerHandle client) evPtr


{- |
Strangly ALSA returns error code 2 (No such file or directory)
if the destination port does not exist.
-}
drainOutput :: Client -> IO ()
drainOutput =
   liftM (const ()) .
   SndSeq.check "drainOutput" .
   SndSeq.drain_output . sequencerHandle


withNamedQueue :: Client -> String -> (SndSeq.Queue -> IO a) -> IO a
withNamedQueue client name =
   bracket
      (liftM
          (SndSeq.Queue . fromIntegral)
          (SndSeq.check "withNamedQueue" (withCString name
              (SndSeq.alloc_named_queue (sequencerHandle client)))))
      (SndSeq.free_queue (sequencerHandle client))


initQueueTempo :: Client -> SndSeq.Queue -> Int -> Int -> IO ()
initQueueTempo client q ppq tempo =
   bracket
      (alloca $ \t ->
          SndSeq.check "initQueueTempo.malloc" (SndSeq.queue_tempo_malloc t) >>
          peek t)
      SndSeq.queue_tempo_free
      (\t ->
          do SndSeq.queue_tempo_set_tempo t (fromIntegral tempo)
             SndSeq.queue_tempo_set_ppq   t (fromIntegral ppq)

             SndSeq.check "initQueueTempo.set_tempo"
                (SndSeq.set_queue_tempo (sequencerHandle client) q t)
             return ())


-- create a new client
createClient :: SndSeq.OpenMode -> String -> IO Client
createClient mode name = alloca $ \handlePtr -> do
    SndSeq.check "createClient" $
       withCString "default" $ \defaultS ->
       SndSeq.open handlePtr defaultS mode 0

    hdl <- peek handlePtr
    withCString name (SndSeq.set_client_name hdl)
    liftM (Client hdl) (newIORef [])



createPort :: SndSeq.PortCapabilitySet -> Client -> String -> IO SndSeq.Port
createPort cap client name = do
    port <-
       SndSeq.check "createPort" $
       withCString name $ \cname ->
       SndSeq.create_simple_port
         (sequencerHandle client)
         cname
         cap
         SndSeq.portTypeMIDIGeneric -- TODO

    let p = SndSeq.Port $ fromIntegral port
    modifyIORef (ports client) (p :)
    return p


createInputPort :: Client -> String -> IO SndSeq.Port
createInputPort =
   createPort (SndSeq.flagsToWord [SndSeq.PortCapRead, SndSeq.PortCapSubsRead])

createOutputPort :: Client -> String -> IO SndSeq.Port
createOutputPort =
   createPort (SndSeq.flagsToWord [SndSeq.PortCapWrite, SndSeq.PortCapSubsWrite])

deletePort :: Client -> SndSeq.Port -> IO ()
deletePort client =
   liftM (const ()) .
   SndSeq.check "deletePort" .
   SndSeq.delete_simple_port (sequencerHandle client)