    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, )

    {- |
    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 :: 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

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

    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