{-
ToDo:
ALSA events may contain values
for channel, pitch, velocity, controller, program that are out of bound.
In this case our conversions yield an error.
-}
module Sound.MIDI.ALSA where

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 Mode

import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )

import qualified Sound.ALSA.Sequencer.Event as Event
import Data.Word (Word8, Word32, )
import Data.Int (Int32, )

import qualified Data.Accessor.Basic as Acc
import Data.Accessor.Basic ((^.), )
import Data.Tuple.HT (mapSnd, )


-- * value conversions

toChannel :: Word8 -> Channel
toChannel  =  ChannelMsg.toChannel . fromIntegral

fromChannel :: Channel -> Word8
fromChannel  =  fromIntegral . ChannelMsg.fromChannel


toPitch :: Word8 -> Pitch
toPitch  =  ChannelMsg.toPitch . fromIntegral

fromPitch :: Pitch -> Word8
fromPitch  =  fromIntegral . ChannelMsg.fromPitch


toVelocity :: Word8 -> Velocity
toVelocity  =  ChannelMsg.toVelocity . fromIntegral

fromVelocity :: Velocity -> Word8
fromVelocity  =  fromIntegral . ChannelMsg.fromVelocity


{- |
Return a 'NoteOff' if input is a 'NoteOn' with velocity zero.
This is a trick of the MIDI standard
in order to allow compression of a series of note events.
After normalization you can safely match on 'NoteOn' and 'NoteOff'.
-}
normalizeNote :: (Event.NoteEv, Velocity) -> (Event.NoteEv, Velocity)
normalizeNote nv@(notePart,velocity) =
   case notePart of
      Event.NoteOn ->
         if velocity == VoiceMsg.toVelocity 0
           then (Event.NoteOff, VoiceMsg.toVelocity VoiceMsg.normalVelocity)
           else (Event.NoteOn, velocity)
      _ -> nv

normalNoteFromEvent :: Event.NoteEv -> Event.Note -> (Event.NoteEv, Velocity)
normalNoteFromEvent notePart note =
   normalizeNote (notePart, note ^. noteVelocity)


{- |
Controllers from @0x78@ to @0x7F@ are special,
you must assert that the controller number is in the range @0@ to @0x77@.
-}
toController :: Word32 -> Controller
toController  =  ChannelMsg.toController . fromIntegral

fromController :: Controller -> Word32
fromController  =  fromIntegral . ChannelMsg.fromController


toProgram :: Int32 -> Program
toProgram  =  ChannelMsg.toProgram . fromIntegral

fromProgram :: Program -> Int32
fromProgram  =  fromIntegral . ChannelMsg.fromProgram


-- * construction of event data records

noteEvent ::
   Channel -> Pitch -> Velocity -> Velocity -> Word32 ->
   Event.Note
noteEvent chan pitch velOn velOff dur =
   Event.Note
      (fromChannel chan)
      (fromPitch pitch)
      (fromVelocity velOn)
      (fromVelocity velOff)
      dur

controllerEvent ::
   Channel -> Controller -> Int32 ->
   Event.Ctrl
controllerEvent chan ctrl value =
   Event.Ctrl
      (fromChannel chan)
      (fromController ctrl)
      value

programChangeEvent ::
   Channel -> Program ->
   Event.Ctrl
programChangeEvent chan pgm =
   Event.Ctrl
      (fromChannel chan)
      0
      (fromProgram pgm)

modeEvent ::
   Channel -> Mode.T ->
   Event.Ctrl
modeEvent chan m =
   case Mode.toControllerValue m of
      (param,value) ->
         Event.Ctrl
            (fromChannel chan)
            param
            (fromIntegral value)


-- * accessors to event data fields

noteChannel :: Acc.T Event.Note Channel
noteChannel =
   Acc.fromSetGet
      (\c note -> note{Event.noteChannel = fromChannel c})
      (toChannel . Event.noteChannel)

notePitch :: Acc.T Event.Note Pitch
notePitch =
   Acc.fromSetGet
      (\p note -> note{Event.noteNote = fromPitch p})
      (toPitch . Event.noteNote)

{- |
This may not yield what you expect.
See 'normalizeNote'.
-}
noteVelocity :: Acc.T Event.Note Velocity
noteVelocity =
   Acc.fromSetGet
      (\v note -> note{Event.noteVelocity = fromVelocity v})
      (toVelocity . Event.noteVelocity)


ctrlChannel :: Acc.T Event.Ctrl Channel
ctrlChannel =
   Acc.fromSetGet
      (\c ctrl -> ctrl{Event.ctrlChannel = fromChannel c})
      (toChannel . Event.ctrlChannel)

{- |
This is undefined, if the controller is no regular controller
but a channel mode message.
Better use 'ctrlControllerMode'.
-}
ctrlController :: Acc.T Event.Ctrl Controller
ctrlController =
   Acc.fromSetGet
      (\c ctrl -> ctrl{Event.ctrlParam = fromController c})
      (toController . Event.ctrlParam)

data ControllerMode =
     Controller Controller Int
   | Mode Mode.T
   deriving (Show, Eq)

ctrlControllerMode :: Acc.T Event.Ctrl ControllerMode
ctrlControllerMode =
   Acc.fromSetGet
      (\cm ctrl ->
         let (p,v) =
                case cm of
                   Controller c x ->
                      (fromController c, fromIntegral x)
                   Mode m ->
                      mapSnd fromIntegral $ Mode.toControllerValue m
         in  ctrl{Event.ctrlParam = p,
                  Event.ctrlValue = v})
      (\ctrl ->
         let c = Event.ctrlParam ctrl
         in  if c<0x78
               then Controller (ctrl ^. ctrlController) (ctrl ^. ctrlValue)
               else Mode $ snd  $ Mode.fromControllerValue
                       (fromIntegral $ Event.ctrlParam ctrl,
                        Event.ctrlValue ctrl))

ctrlValue :: Acc.T Event.Ctrl Int
ctrlValue =
   Acc.fromSetGet
      (\x ctrl -> ctrl{Event.ctrlValue = fromIntegral x})
      (fromIntegral . Event.ctrlValue)

ctrlProgram :: Acc.T Event.Ctrl Program
ctrlProgram =
   Acc.fromSetGet
      (\p ctrl -> ctrl{Event.ctrlValue = fromProgram p})
      (toProgram . Event.ctrlValue)