diff --git a/midi-alsa.cabal b/midi-alsa.cabal --- a/midi-alsa.cabal +++ b/midi-alsa.cabal @@ -1,5 +1,5 @@ Name: midi-alsa -Version: 0.1.3 +Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -14,13 +14,14 @@ This package provides accessors to data structures of the ALSA sequencer interface via the more specific types from the @midi@ package. - The package also contains an orphan instance - for the @alsa-seq:Event@ type of the @midi:Message.Class.Check@ class. -Tested-With: GHC==6.10.4 + The package also contains a orphan instances + for the @alsa-seq:Event@ type + of the @midi:Message.Class.Check@ and @midi:Message.Class.Query@ classes. +Tested-With: GHC==6.10.4, GHC==6.12.3, GHC==7.4.1 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository this - Tag: 0.1.3 + Tag: 0.2 Type: darcs Location: http://code.haskell.org/alsa/midi/ @@ -37,8 +38,8 @@ Library Build-Depends: - midi >=0.1.7 && <0.2, - alsa-seq >=0.5 && <0.6, + midi >=0.2 && <0.3, + alsa-seq >=0.6 && <0.7, data-accessor >=0.2.1 && <0.3, utility-ht >=0.0.5 && <0.1 If flag(splitBase) @@ -53,3 +54,4 @@ Exposed-Modules: Sound.MIDI.ALSA Sound.MIDI.ALSA.Check + Sound.MIDI.ALSA.Query diff --git a/src/Sound/MIDI/ALSA.hs b/src/Sound/MIDI/ALSA.hs --- a/src/Sound/MIDI/ALSA.hs +++ b/src/Sound/MIDI/ALSA.hs @@ -14,35 +14,33 @@ 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, ) +import Data.Tuple.HT (mapPair, ) -- * value conversions -toChannel :: Word8 -> Channel -toChannel = ChannelMsg.toChannel . fromIntegral +toChannel :: Event.Channel -> Channel +toChannel = ChannelMsg.toChannel . fromIntegral . Event.unChannel -fromChannel :: Channel -> Word8 -fromChannel = fromIntegral . ChannelMsg.fromChannel +fromChannel :: Channel -> Event.Channel +fromChannel = Event.Channel . fromIntegral . ChannelMsg.fromChannel -toPitch :: Word8 -> Pitch -toPitch = ChannelMsg.toPitch . fromIntegral +toPitch :: Event.Pitch -> Pitch +toPitch = ChannelMsg.toPitch . fromIntegral . Event.unPitch -fromPitch :: Pitch -> Word8 -fromPitch = fromIntegral . ChannelMsg.fromPitch +fromPitch :: Pitch -> Event.Pitch +fromPitch = Event.Pitch . fromIntegral . ChannelMsg.fromPitch -toVelocity :: Word8 -> Velocity -toVelocity = ChannelMsg.toVelocity . fromIntegral +toVelocity :: Event.Velocity -> Velocity +toVelocity = ChannelMsg.toVelocity . fromIntegral . Event.unVelocity -fromVelocity :: Velocity -> Word8 -fromVelocity = fromIntegral . ChannelMsg.fromVelocity +fromVelocity :: Velocity -> Event.Velocity +fromVelocity = Event.Velocity . fromIntegral . ChannelMsg.fromVelocity {- | @@ -56,7 +54,7 @@ case notePart of Event.NoteOn -> if velocity == VoiceMsg.toVelocity 0 - then (Event.NoteOff, VoiceMsg.toVelocity VoiceMsg.normalVelocity) + then (Event.NoteOff, VoiceMsg.normalVelocity) else (Event.NoteOn, velocity) _ -> nv @@ -69,24 +67,24 @@ 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 +toController :: Event.Parameter -> Controller +toController = ChannelMsg.toController . fromIntegral . Event.unParameter -fromController :: Controller -> Word32 -fromController = fromIntegral . ChannelMsg.fromController +fromController :: Controller -> Event.Parameter +fromController = Event.Parameter . fromIntegral . ChannelMsg.fromController -toProgram :: Int32 -> Program -toProgram = ChannelMsg.toProgram . fromIntegral +toProgram :: Event.Value -> Program +toProgram = ChannelMsg.toProgram . fromIntegral . Event.unValue -fromProgram :: Program -> Int32 -fromProgram = fromIntegral . ChannelMsg.fromProgram +fromProgram :: Program -> Event.Value +fromProgram = Event.Value . fromIntegral . ChannelMsg.fromProgram -- * construction of event data records noteEvent :: - Channel -> Pitch -> Velocity -> Velocity -> Word32 -> + Channel -> Pitch -> Velocity -> Velocity -> Int -> Event.Note noteEvent chan pitch velOn velOff dur = Event.Note @@ -94,16 +92,16 @@ (fromPitch pitch) (fromVelocity velOn) (fromVelocity velOff) - dur + (Event.Duration $ fromIntegral dur) controllerEvent :: - Channel -> Controller -> Int32 -> + Channel -> Controller -> Int -> Event.Ctrl controllerEvent chan ctrl value = Event.Ctrl (fromChannel chan) (fromController ctrl) - value + (Event.Value $ fromIntegral value) programChangeEvent :: Channel -> Program -> @@ -111,7 +109,7 @@ programChangeEvent chan pgm = Event.Ctrl (fromChannel chan) - 0 + (Event.Parameter 0) (fromProgram pgm) modeEvent :: @@ -122,8 +120,8 @@ (param,value) -> Event.Ctrl (fromChannel chan) - param - (fromIntegral value) + (Event.Parameter $ fromIntegral param) + (Event.Value value) -- * accessors to event data fields @@ -182,22 +180,23 @@ Controller c x -> (fromController c, fromIntegral x) Mode m -> - mapSnd fromIntegral $ Mode.toControllerValue m + mapPair (Event.Parameter, fromIntegral) $ + Mode.toControllerValue m in ctrl{Event.ctrlParam = p, - Event.ctrlValue = v}) + Event.ctrlValue = Event.Value v}) (\ctrl -> let c = Event.ctrlParam ctrl - in if c<0x78 + in if c < Event.Parameter 0x78 then Controller (ctrl ^. ctrlController) (ctrl ^. ctrlValue) - else Mode $ snd $ Mode.fromControllerValue - (fromIntegral $ Event.ctrlParam ctrl, - Event.ctrlValue ctrl)) + else Mode $ snd $ Mode.fromControllerValue + (Event.unParameter $ Event.ctrlParam ctrl, + fromIntegral $ Event.unValue $ Event.ctrlValue ctrl)) ctrlValue :: Acc.T Event.Ctrl Int ctrlValue = Acc.fromSetGet - (\x ctrl -> ctrl{Event.ctrlValue = fromIntegral x}) - (fromIntegral . Event.ctrlValue) + (\x ctrl -> ctrl{Event.ctrlValue = Event.Value $ fromIntegral x}) + (fromIntegral . Event.unValue . Event.ctrlValue) ctrlProgram :: Acc.T Event.Ctrl Program ctrlProgram = diff --git a/src/Sound/MIDI/ALSA/Check.hs b/src/Sound/MIDI/ALSA/Check.hs --- a/src/Sound/MIDI/ALSA/Check.hs +++ b/src/Sound/MIDI/ALSA/Check.hs @@ -1,10 +1,19 @@ {- -The instance Class.C Event.T is orphan. +The instances Class.C Event.T and Class.C Event.Data are orphan. I could put it in package 'midi' or 'alsa-seq' -but in both them it imposes a lot of new dependencies. +but in both of them it imposes a lot of new dependencies. -} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Sound.MIDI.ALSA.Check where +module Sound.MIDI.ALSA.Check ( + Class.C, + Class.note, + Class.program, + Class.anyController, + Class.controller, + Class.mode, + Class.pitchBend, + Class.channelPressure, + ) where import qualified Sound.MIDI.Message.Class.Check as Class import qualified Sound.MIDI.Message.Channel.Mode as Mode @@ -22,18 +31,26 @@ instance Class.C Event.T where - note = note - program = program - anyController = anyController - mode = mode - pitchBend = pitchBend - channelPressure = channelPressure + note chan = noteData chan . Event.body + program chan = programData chan . Event.body + anyController chan = anyControllerData chan . Event.body + mode chan = modeData chan . Event.body + pitchBend chan = pitchBendData chan . Event.body + channelPressure chan = channelPressureData chan . Event.body +instance Class.C Event.Data where + note = noteData + program = programData + anyController = anyControllerData + mode = modeData + pitchBend = pitchBendData + channelPressure = channelPressureData -note :: - Channel -> Event.T -> Maybe (Velocity, Pitch, Bool) -note chan e = do - Event.NoteEv n c <- Just $ Event.body e + +noteData :: + Channel -> Event.Data -> Maybe (Velocity, Pitch, Bool) +noteData chan e = do + Event.NoteEv n c <- Just e guard (c ^. MALSA.noteChannel == chan) let pitch = c ^. MALSA.notePitch velocity = c ^. MALSA.noteVelocity @@ -42,47 +59,41 @@ Event.NoteOff -> Just (velocity, pitch, False) _ -> Nothing -program :: - Channel -> Event.T -> Maybe Program -program chan e = do - Event.CtrlEv Event.PgmChange c <- Just $ Event.body e +programData :: + Channel -> Event.Data -> Maybe Program +programData chan e = do + Event.CtrlEv Event.PgmChange c <- Just e guard (c ^. MALSA.ctrlChannel == chan) return $ c ^. MALSA.ctrlProgram -anyController :: - Channel -> Event.T -> Maybe (Controller, Int) -anyController chan e = do +anyControllerData :: + Channel -> Event.Data -> Maybe (Controller, Int) +anyControllerData chan e = do -- let Event.TickTime n = Event.timestamp e - Event.CtrlEv Event.Controller c <- Just $ Event.body e + Event.CtrlEv Event.Controller c <- Just e guard (c ^. MALSA.ctrlChannel == chan) MALSA.Controller cn cv <- Just $ c ^. MALSA.ctrlControllerMode return (cn, cv) -controller :: Channel -> Controller -> Event.T -> Maybe Int -controller chan ctrl e = do - (c,n) <- anyController chan e - guard (ctrl==c) - return n - -mode :: Channel -> Event.T -> Maybe Mode.T -mode chan e = do - Event.CtrlEv Event.Controller c <- Just $ Event.body e +modeData :: Channel -> Event.Data -> Maybe Mode.T +modeData chan e = do + Event.CtrlEv Event.Controller c <- Just e guard (c ^. MALSA.ctrlChannel == chan) MALSA.Mode m <- Just $ c ^. MALSA.ctrlControllerMode return m -pitchBend :: Channel -> Event.T -> Maybe Int -pitchBend chan e = - case Event.body e of +pitchBendData :: Channel -> Event.Data -> Maybe Int +pitchBendData chan e = + case e of Event.CtrlEv Event.PitchBend c -> toMaybe (c ^. MALSA.ctrlChannel == chan) (c ^. MALSA.ctrlValue) _ -> Nothing -channelPressure :: Channel -> Event.T -> Maybe Int -channelPressure chan e = - case Event.body e of +channelPressureData :: Channel -> Event.Data -> Maybe Int +channelPressureData chan e = + case e of Event.CtrlEv Event.ChanPress c -> toMaybe (c ^. MALSA.ctrlChannel == chan) diff --git a/src/Sound/MIDI/ALSA/Query.hs b/src/Sound/MIDI/ALSA/Query.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/ALSA/Query.hs @@ -0,0 +1,91 @@ +{- +The instances Class.C Event.T and Class.C Event.Data are orphan. +I could put it in package 'midi' or 'alsa-seq' +but in both of them it imposes a lot of new dependencies. +-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Sound.MIDI.ALSA.Query ( + Class.C, + Class.note, + Class.program, + Class.anyController, + Class.mode, + Class.pitchBend, + Class.channelPressure, + ) where + +import qualified Sound.MIDI.Message.Class.Query as Class +import qualified Sound.MIDI.Message.Channel.Mode as Mode + +import qualified Sound.MIDI.ALSA as MALSA + +import qualified Sound.ALSA.Sequencer.Event as Event + +import Sound.MIDI.Message.Channel (Channel, ) +import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Controller, Program, ) + +import Data.Accessor.Basic ((^.), ) + + +instance Class.C Event.T where + note = noteData . Event.body + program = programData . Event.body + anyController = anyControllerData . Event.body + mode = modeData . Event.body + pitchBend = pitchBendData . Event.body + channelPressure = channelPressureData . Event.body + +instance Class.C Event.Data where + note = noteData + program = programData + anyController = anyControllerData + mode = modeData + pitchBend = pitchBendData + channelPressure = channelPressureData + + +noteData :: + Event.Data -> Maybe (Channel, (Velocity, Pitch, Bool)) +noteData e = do + Event.NoteEv n c <- Just e + let pitch = c ^. MALSA.notePitch + velocity = c ^. MALSA.noteVelocity + fmap ((,) (c ^. MALSA.noteChannel)) $ + case n of + Event.NoteOn -> Just (velocity, pitch, True) + Event.NoteOff -> Just (velocity, pitch, False) + _ -> Nothing + +programData :: + Event.Data -> Maybe (Channel, Program) +programData e = do + Event.CtrlEv Event.PgmChange c <- Just e + return (c ^. MALSA.ctrlChannel, c ^. MALSA.ctrlProgram) + +anyControllerData :: + Event.Data -> Maybe (Channel, (Controller, Int)) +anyControllerData e = do + -- let Event.TickTime n = Event.timestamp e + Event.CtrlEv Event.Controller c <- Just e + MALSA.Controller cn cv <- Just $ c ^. MALSA.ctrlControllerMode + return (c ^. MALSA.ctrlChannel, (cn, cv)) + +modeData :: Event.Data -> Maybe (Channel, Mode.T) +modeData e = do + Event.CtrlEv Event.Controller c <- Just e + MALSA.Mode m <- Just $ c ^. MALSA.ctrlControllerMode + return (c ^. MALSA.ctrlChannel, m) + +pitchBendData :: Event.Data -> Maybe (Channel, Int) +pitchBendData e = + case e of + Event.CtrlEv Event.PitchBend c -> + Just (c ^. MALSA.ctrlChannel, c ^. MALSA.ctrlValue) + _ -> Nothing + +channelPressureData :: Event.Data -> Maybe (Channel, Int) +channelPressureData e = + case e of + Event.CtrlEv Event.ChanPress c -> + Just (c ^. MALSA.ctrlChannel, c ^. MALSA.ctrlValue) + _ -> Nothing