module Sound.MIDI.Message.Class.Check 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

import Control.Monad (guard, )


class C event where
   note :: Channel -> event -> Maybe (Velocity, Pitch, Bool)
   program :: Channel -> event -> Maybe Program
   anyController :: Channel -> event -> Maybe (Controller, Int)
   pitchBend :: Channel -> event -> Maybe Int
   channelPressure :: Channel -> event -> Maybe Int
   mode :: Channel -> event -> Maybe Mode.T

controller ::
   (C event) =>
   Channel -> Controller -> event -> Maybe Int
controller chan ctrl e = do
   (c,n) <- anyController chan e
   guard (ctrl==c)
   return n


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

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

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

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

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

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


liftMidi ::
   (Channel -> ChannelMsg.T -> Maybe a) ->
   (Channel -> MidiMsg.T -> Maybe a)
liftMidi checkMsg chan msg =
   case msg of
      MidiMsg.Channel chanMsg -> checkMsg chan 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