    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