midi 0.1.7.1 → 0.2
raw patch · 8 files changed
+339/−103 lines, 8 filesdep ~transformers
Dependency ranges changed: transformers
Files
- midi.cabal +5/−3
- src/Sound/MIDI/File.hs +1/−1
- src/Sound/MIDI/File/Event/Meta.hs +17/−75
- src/Sound/MIDI/KeySignature.hs +183/−0
- src/Sound/MIDI/Message/Channel/Voice.hs +26/−23
- src/Sound/MIDI/Message/Class/Check.hs +17/−0
- src/Sound/MIDI/Message/Class/Query.hs +86/−0
- src/Sound/MIDI/Parser/File.hs +4/−1
midi.cabal view
@@ -1,5 +1,5 @@ Name: midi-Version: 0.1.7.1+Version: 0.2 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -30,7 +30,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/midi/- tag: 0.1.7.1+ tag: 0.2 Flag splitBase description: Choose the new smaller, split-up base package.@@ -46,7 +46,7 @@ explicit-exception >=0.1 && <0.2, bytestring >=0.9.0.1 && <0.10, binary >=0.4.2 && <0.6,- transformers >=0.2 && <0.3,+ transformers >=0.2 && <0.4, monoid-transformer >=0.0.1 && <0.1, QuickCheck >=1 && <3 If flag(splitBase)@@ -76,8 +76,10 @@ Sound.MIDI.Message.System.Common Sound.MIDI.Message.System.RealTime Sound.MIDI.Message.Class.Check+ Sound.MIDI.Message.Class.Query Sound.MIDI.Controller Sound.MIDI.Manufacturer+ Sound.MIDI.KeySignature Sound.MIDI.General -- exports ByteList data type Sound.MIDI.IO
src/Sound/MIDI/File.hs view
@@ -142,7 +142,7 @@ EventList.T NonNegW.Rational Event.T secondsFromTicks division = EventList.catMaybes .- flip MS.evalState MetaEvent.defltST .+ flip MS.evalState MetaEvent.defltTempo . EventList.mapM (\ticks -> do microsPerQN <- MS.get
src/Sound/MIDI/File/Event/Meta.hs view
@@ -1,19 +1,20 @@ module Sound.MIDI.File.Event.Meta ( T(..),- Key(..), Scale(..), ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo,+ defltTempo, SMPTEHours, SMPTEMinutes, SMPTESeconds, SMPTEFrames, SMPTEBits,- defltST, defltDurT, get, put, ) where import Sound.MIDI.Message.Channel (Channel, toChannel, fromChannel, ) -import Sound.MIDI.Parser.Primitive+import qualified Sound.MIDI.KeySignature as KeySig++import Sound.MIDI.Parser.Primitive (get1, get2, get3, getVar, getBigN, ) import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as ParserRestricted -import Control.Monad (liftM, liftM2, liftM4, liftM5, )+import Control.Monad (liftM, liftM4, liftM5, ) import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit@@ -23,14 +24,11 @@ import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, listCharFromByte, listByteFromChar, ) -import Data.Ix (Ix, index, ) import Sound.MIDI.Utility- (arbitraryString, arbitraryByteList,- enumRandomR, boundedEnumRandom, chooseEnum, )+ (arbitraryString, arbitraryByteList, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC-import System.Random (Random(random, randomR), ) import Prelude hiding (putStr, ) @@ -59,7 +57,7 @@ | SetTempo Tempo | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits | TimeSig Int Int Int Int- | KeySig Key Scale+ | KeySig KeySig.T | SequencerSpecific ByteList | Unknown Int ByteList deriving (Show, Eq, Ord)@@ -81,7 +79,7 @@ liftM (SetTempo . NonNeg.fromNumberMsg "Tempo always positive") (QC.choose (0,0xFFFFFF)) : liftM5 SMPTEOffset arbitraryByte arbitraryByte arbitraryByte arbitraryByte arbitraryByte : liftM4 TimeSig arbitraryByte arbitraryByte arbitraryByte arbitraryByte :- liftM2 KeySig arbitrary arbitrary :+ liftM KeySig arbitrary : liftM SequencerSpecific arbitraryByteList : -- liftM Unknown arbitrary arbitraryByteList : []@@ -90,57 +88,6 @@ arbitraryByte = QC.choose (0,0xFF::Int) -{- |-The following enumerated type lists all the keys in order of their key-signatures from flats to sharps.-(@Cf@ = 7 flats, @Gf@ = 6 flats ... @F@ = 1 flat, @C@ = 0 flats\/sharps,-@G@ = 1 sharp, ... @Cs@ = 7 sharps.)-Useful for transposition.--}-data Key = KeyCf | KeyGf | KeyDf | KeyAf | KeyEf | KeyBf | KeyF- | KeyC | KeyG | KeyD | KeyA | KeyE | KeyB | KeyFs | KeyCs- deriving (Show, Eq, Ord, Ix, Enum, Bounded)---instance Random Key where- random = boundedEnumRandom- randomR = enumRandomR--instance Arbitrary Key where- arbitrary = chooseEnum----{- |-The Key Signature specifies a mode, either major or minor.--}-data Scale = Major | Minor- deriving (Show, Eq, Ord, Ix, Enum, Bounded)---instance Random Scale where- random = boundedEnumRandom- randomR = enumRandomR--instance Arbitrary Scale where- arbitrary = chooseEnum----{- |-Default number of quarter notes in a second.--}-defltDurT :: ElapsedTime-defltDurT = 2--{- |-The default SetTempo value, in microseconds per quarter note.-This expresses the default of 120 beats per minute.--}-defltST :: Tempo-defltST = div 1000000 (fromIntegral defltDurT)-- toElapsedTime :: Integer -> ElapsedTime toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime" @@ -154,8 +101,15 @@ fromTempo :: Tempo -> Int fromTempo = NonNeg.toNumber +{- |+The default SetTempo value, in microseconds per quarter note.+This expresses the default of 120 beats per minute.+-}+defltTempo :: Tempo+defltTempo = 500000 + -- * serialization get :: Parser.C parser => Parser.Fallible parser T@@ -193,21 +147,13 @@ b <- get1 return (TimeSig n d c b) - 089 -> parse $- do- sf <- get1- sc <- getEnum- return (KeySig (toKeyName sf) sc)+ 089 -> parse $ liftM KeySig KeySig.get 127 -> liftM SequencerSpecific $ getBigN len _ -> liftM (Unknown code) $ getBigN len -toKeyName :: Int -> Key-toKeyName sf = toEnum (mod (sf+7) 15) -- put :: Writer.C writer => T -> writer put ev = Writer.putByte 255 +#+@@ -227,11 +173,7 @@ SMPTEOffset hr mn se fr ff -> putList 84 [hr,mn,se,fr,ff] TimeSig n d c b -> putList 88 [n,d,c,b]- KeySig sf mi -> putList 89 [sf', fromEnum mi]- where k = index (KeyCf,KeyCs) sf - 7- sf' = if k >= 0- then k- else 255+k+ KeySig key -> putList 89 $ KeySig.toBytes key SequencerSpecific codes -> putByteList 127 codes Unknown typ s -> putByteList typ s
+ src/Sound/MIDI/KeySignature.hs view
@@ -0,0 +1,183 @@+module Sound.MIDI.KeySignature (+ T(..),+ Accidentals(..), Mode(..), keyName,++ cfMajor, gfMajor, dfMajor, afMajor, efMajor,+ bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor,+ eMajor, bMajor, fsMajor, csMajor,+ afMinor, efMinor, bfMinor, fMinor, cMinor,+ gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor,+ csMinor, gsMinor, dsMinor, asMinor,++ get, toBytes, ) where++import Sound.MIDI.Parser.Primitive (getByte, getEnum, makeEnum, )+import qualified Sound.MIDI.Parser.Class as Parser++import Control.Monad (liftM2, )++import Data.Ix (Ix, inRange, )+import Sound.MIDI.Utility+ (enumRandomR, boundedEnumRandom, chooseEnum, checkRange, )++import Test.QuickCheck (Arbitrary(arbitrary), )+import qualified Test.QuickCheck as QC+import System.Random (Random(random, randomR), )++import Data.Int (Int8, )++import Prelude hiding (putStr, )++++data T = Cons Mode Accidentals+ deriving (Eq, Ord)++instance Show T where+ showsPrec p (Cons mode accs) =+ if inRange (minBound, maxBound) accs+ then showString "KeySig." .+ showString (keyName mode accs) . shows mode+ else showParen (p>10) $+ showString "KeySig.Cons " . shows mode .+ showString " " . showsPrec 11 accs++instance Arbitrary T where+ arbitrary = liftM2 Cons arbitrary arbitrary++{- |+The Key Signature specifies a mode, either major or minor.+-}+data Mode = Major | Minor+ deriving (Show, Eq, Ord, Ix, Enum, Bounded)+++instance Random Mode where+ random = boundedEnumRandom+ randomR = enumRandomR++instance Arbitrary Mode where+ arbitrary = chooseEnum++++++keyName :: Mode -> Accidentals -> String++keyName Major (Accidentals (-7)) = "cf"+keyName Major (Accidentals (-6)) = "gf"+keyName Major (Accidentals (-5)) = "df"+keyName Major (Accidentals (-4)) = "af"+keyName Major (Accidentals (-3)) = "ef"+keyName Major (Accidentals (-2)) = "bf"+keyName Major (Accidentals (-1)) = "f"+keyName Major (Accidentals 0) = "c"+keyName Major (Accidentals 1) = "g"+keyName Major (Accidentals 2) = "d"+keyName Major (Accidentals 3) = "a"+keyName Major (Accidentals 4) = "e"+keyName Major (Accidentals 5) = "b"+keyName Major (Accidentals 6) = "fs"+keyName Major (Accidentals 7) = "cs"++keyName Minor (Accidentals (-7)) = "af"+keyName Minor (Accidentals (-6)) = "ef"+keyName Minor (Accidentals (-5)) = "bf"+keyName Minor (Accidentals (-4)) = "f"+keyName Minor (Accidentals (-3)) = "c"+keyName Minor (Accidentals (-2)) = "g"+keyName Minor (Accidentals (-1)) = "d"+keyName Minor (Accidentals 0) = "a"+keyName Minor (Accidentals 1) = "e"+keyName Minor (Accidentals 2) = "b"+keyName Minor (Accidentals 3) = "fs"+keyName Minor (Accidentals 4) = "cs"+keyName Minor (Accidentals 5) = "gs"+keyName Minor (Accidentals 6) = "ds"+keyName Minor (Accidentals 7) = "as"++keyName _ (Accidentals n) =+ if n<0+ then show (-n) ++ " flats"+ else show n ++ " sharps"+++{- |+Accidentals as used in key signature.+-}+newtype Accidentals = Accidentals Int+ deriving (Show, Eq, Ord, Ix)++instance Bounded Accidentals where+ minBound = Accidentals (-7)+ maxBound = Accidentals 7++instance Enum Accidentals where+ fromEnum (Accidentals n) = fromIntegral n+ toEnum = checkRange "Accidentals" (Accidentals . fromIntegral)++instance Random Accidentals where+ random = boundedEnumRandom+ randomR = enumRandomR++instance Arbitrary Accidentals where+ arbitrary = chooseEnum+++++major, minor :: Accidentals -> T+major = Cons Major+minor = Cons Minor++cfMajor, gfMajor, dfMajor, afMajor, efMajor,+ bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor,+ eMajor, bMajor, fsMajor, csMajor :: T++afMinor, efMinor, bfMinor, fMinor, cMinor,+ gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor,+ csMinor, gsMinor, dsMinor, asMinor :: T++cfMajor = major (Accidentals (-7))+gfMajor = major (Accidentals (-6))+dfMajor = major (Accidentals (-5))+afMajor = major (Accidentals (-4))+efMajor = major (Accidentals (-3))+bfMajor = major (Accidentals (-2))+fMajor = major (Accidentals (-1))+cMajor = major (Accidentals 0)+gMajor = major (Accidentals 1)+dMajor = major (Accidentals 2)+aMajor = major (Accidentals 3)+eMajor = major (Accidentals 4)+bMajor = major (Accidentals 5)+fsMajor = major (Accidentals 6)+csMajor = major (Accidentals 7)++afMinor = minor (Accidentals (-7))+efMinor = minor (Accidentals (-6))+bfMinor = minor (Accidentals (-5))+fMinor = minor (Accidentals (-4))+cMinor = minor (Accidentals (-3))+gMinor = minor (Accidentals (-2))+dMinor = minor (Accidentals (-1))+aMinor = minor (Accidentals 0)+eMinor = minor (Accidentals 1)+bMinor = minor (Accidentals 2)+fsMinor = minor (Accidentals 3)+csMinor = minor (Accidentals 4)+gsMinor = minor (Accidentals 5)+dsMinor = minor (Accidentals 6)+asMinor = minor (Accidentals 7)+++get :: (Parser.C parser) => Parser.Fallible parser T+get = liftM2 (flip Cons) getAccidentals getEnum++getAccidentals :: (Parser.C parser) => Parser.Fallible parser Accidentals+getAccidentals =+ makeEnum . fromIntegral . (id :: Int8 -> Int8) . fromIntegral =<< getByte++toBytes :: T -> [Int]+toBytes (Cons mi sf) = [fromEnum sf, fromEnum mi]
src/Sound/MIDI/Message/Channel/Voice.hs view
@@ -6,7 +6,7 @@ ControllerValue, PitchBendRange, Pressure, isNote, isNoteOn, isNoteOff, zeroKey, explicitNoteOff, implicitNoteOff,- toFloatController,+ realFromControllerValue, bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, mainVolume, balance, panorama, expression,@@ -35,7 +35,7 @@ CtrlP.Controller, CtrlP.fromController, CtrlP.toController, increasePitch, subtractPitch, frequencyFromPitch,- maximumVelocity, normalVelocity, toFloatVelocity,+ maximumVelocity, normalVelocity, realFromVelocity, ) where import qualified Sound.MIDI.ControllerPrivate as CtrlP@@ -223,6 +223,14 @@ minBound = Pitch 0 maxBound = Pitch 127 +{- |+ToDo:+We have defined minBound = Velocity 0,+but strictly spoken the minimum Velocity is 1,+since Velocity zero means NoteOff.+One can at least think of NoteOff with (Velocity 0),+but I have never seen that.+-} instance Bounded Velocity where minBound = Velocity 0 maxBound = Velocity 127@@ -249,33 +257,28 @@ {- | The velocity of an ordinary key stroke and the maximum possible velocity.--ToDo:-This should be of type Velocity. -}-normalVelocity, maximumVelocity :: Num quant => quant- -- Velocity-normalVelocity = 64-maximumVelocity = 127+normalVelocity, maximumVelocity :: Velocity+normalVelocity = Velocity 64+maximumVelocity = maxBound {- |-64 is given as default value by the MIDI specification-and thus we map it to 1.-0 is mapped to 0.-All other values are interpolated linearly.--ToDo: MIDI specification says, if velocity is simply mapped to amplitude, then this should be done by an exponential function.-Thus we should be better map 'normalVelocity' to 0,-'maximumVelocity' to 1,-and 'minimumVelocity' to -1.+Thus we map 'normalVelocity' (64) to 0,+'maximumVelocity' (127) to 1,+and 'minimumVelocity' (1) to -1.+That is, normally you should write something like+@amplitude = 2 ** realFromVelocity vel@ or @3 ** realFromVelocity vel@. -}-toFloatVelocity :: (Integral a, Fractional b) => a -> b-toFloatVelocity x = fromIntegral x / normalVelocity+realFromVelocity :: (Fractional b) => Velocity -> b+realFromVelocity (Velocity x) =+ fromIntegral (x - fromVelocity normalVelocity) /+ fromIntegral (fromVelocity maximumVelocity - fromVelocity normalVelocity) -maximumControllerValue :: Num quant => quant++maximumControllerValue :: Num a => a maximumControllerValue = 127 {- |@@ -283,8 +286,8 @@ Maximum integral MIDI controller value 127 is mapped to 1. Minimum integral MIDI controller value 0 is mapped to 0. -}-toFloatController :: (Integral a, Fractional b) => a -> b-toFloatController x = fromIntegral x / maximumControllerValue+realFromControllerValue :: (Integral a, Fractional b) => a -> b+realFromControllerValue x = fromIntegral x / maximumControllerValue
src/Sound/MIDI/Message/Class/Check.hs view
@@ -11,6 +11,15 @@ 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@@ -18,6 +27,14 @@ 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) =>
+ src/Sound/MIDI/Message/Class/Query.hs view
@@ -0,0 +1,86 @@+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
src/Sound/MIDI/Parser/File.hs view
@@ -63,10 +63,13 @@ fromIO :: (IO.Handle -> IO a) -> T a fromIO act = Cons $ lift . act =<< ask +ioeTry :: IO a -> IO (Either IOError a)+ioeTry = Exc.try+ fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a fallibleFromIO act = Sync.ExceptionalT . Cons . lift .- fmap (Sync.mapException show . Sync.fromEither) . IOE.try . act+ fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act =<< lift (Cons ask) instance Parser.EndCheck T where