module Sound.MIDI.Message.Class.Query where

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

import qualified Sound.MIDI.Message as MidiMsg
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


{- |
All methods have default implementations that return 'Nothing'.
This helps implementing event data types
that support only a subset of types of events.

Maybe a better approach is to provide type classes
for every type of event
and make 'C' a subclass of all of them.
-}
class C event where
   note :: event -> Maybe (Channel, (Velocity, Pitch, Bool))
   program :: event -> Maybe (Channel, Program)
   anyController :: event -> Maybe (Channel, (Controller, Int))
   pitchBend :: event -> Maybe (Channel, Int)
   channelPressure :: event -> Maybe (Channel, Int)
   mode :: event -> Maybe (Channel, Mode.T)

   note _ev = Nothing
   program _ev = Nothing
   anyController _ev = Nothing
   pitchBend _ev = Nothing
   channelPressure _ev = Nothing
   mode _ev = Nothing


instance C ChannelMsg.T where
   note msg = do
      ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg
      fmap ((,) (ChannelMsg.messageChannel msg)) $ 
         case voice of
            VoiceMsg.NoteOn  pitch velocity -> Just (velocity, pitch, True)
            VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False)
            _ -> Nothing

   program msg = do
      ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <-
         Just $ ChannelMsg.messageBody msg
      return (ChannelMsg.messageChannel msg, pgm)

   anyController msg = do
      ChannelMsg.Voice (VoiceMsg.Control ctrl val) <-
         Just $ ChannelMsg.messageBody msg
      return (ChannelMsg.messageChannel msg, (ctrl, val))

   pitchBend msg = do
      ChannelMsg.Voice (VoiceMsg.PitchBend bend) <-
         Just $ ChannelMsg.messageBody msg
      return (ChannelMsg.messageChannel msg, bend)

   channelPressure msg = do
      ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <-
         Just $ ChannelMsg.messageBody msg
      return (ChannelMsg.messageChannel msg, pressure)

   mode msg = do
      ChannelMsg.Mode m <-
         Just $ ChannelMsg.messageBody msg
      return (ChannelMsg.messageChannel msg, m)


liftMidi ::
   (ChannelMsg.T -> Maybe (Channel, a)) ->
   (MidiMsg.T -> Maybe (Channel, a))
liftMidi checkMsg msg =
   case msg of
      MidiMsg.Channel chanMsg -> checkMsg chanMsg
      _ -> Nothing

instance C MidiMsg.T where
   note = liftMidi note
   program = liftMidi program
   anyController = liftMidi anyController
   pitchBend = liftMidi pitchBend
   channelPressure = liftMidi channelPressure
   mode = liftMidi mode