diff --git a/midi.cabal b/midi.cabal --- a/midi.cabal +++ b/midi.cabal @@ -1,5 +1,5 @@ Name: midi -Version: 0.0.7 +Version: 0.1.1 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -11,9 +11,10 @@ Synopsis: Handling of MIDI messages and files Description: MIDI is the Musical Instrument Digital Interface. - The package contains definition of MIDI messages, + The package contains definition of realtime and file MIDI messages, reading and writing MIDI files. - It contains no sending and receiving of MIDI messages. Cf. alsa-midi package. + It contains no sending and receiving of MIDI messages. + Cf. alsa-midi, jack-midi and hmidi packages. For music composition with MIDI output, see Haskore. Tested-With: GHC==6.4.1 && ==6.8.2 Cabal-Version: >=1.2 @@ -22,30 +23,67 @@ Flag splitBase description: Choose the new smaller, split-up base package. +Flag buildTests + description: Build test executables + default: False + Library Build-Depends: event-list >=0.0.6 && < 0.1, non-negative>=0.0.1 && <0.1 + Build-Depends: bytestring >=0.9.0.1 && <0.10, binary >=0.4.2 && <0.5 Build-Depends: mtl >=1 && <2, QuickCheck >=1 && <2 If flag(splitBase) Build-Depends: base >= 2, random Else Build-Depends: base >= 1.0 && < 2 -- Instead of the full-blown Monad Template Library with multi-parameter type classes with functional dependencies - -- we also be happy with the less expensive + -- we would also be happy with the less expensive -- http://darcs.haskell.org/packages/mtl-split/Control/Monad/Trans/State.hs GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: - Sound.MIDI.Event Sound.MIDI.File + Sound.MIDI.File.Event + Sound.MIDI.File.Event.Meta + Sound.MIDI.File.Event.SystemExclusive Sound.MIDI.File.Load Sound.MIDI.File.Save - -- exports ByteString data type + Sound.MIDI.Parser.Report + Sound.MIDI.Message + Sound.MIDI.Message.Channel + Sound.MIDI.Message.Channel.Voice + Sound.MIDI.Message.Channel.Mode + Sound.MIDI.Message.System + Sound.MIDI.Message.System.Exclusive + Sound.MIDI.Message.System.Common + Sound.MIDI.Message.System.RealTime + Sound.MIDI.Manufacturer Sound.MIDI.General + -- exports ByteList data type Sound.MIDI.IO Other-Modules: Sound.MIDI.Bit - Sound.MIDI.Parser - Sound.MIDI.ParserState + -- Parser class and general parser functions + Sound.MIDI.Parser.Class + Sound.MIDI.Parser.Restricted + Sound.MIDI.Parser.State + Sound.MIDI.Parser.Primitive + Sound.MIDI.Parser.Status + -- concrete Parsers + Sound.MIDI.Parser.File + Sound.MIDI.Parser.Stream + Sound.MIDI.Parser.ByteString + Sound.MIDI.Writer.Basic + Sound.MIDI.Writer.Status Sound.MIDI.String Sound.MIDI.Utility + +Executable test + If !flag(buildTests) + Buildable: False + +-- this will put Cabal into an infinite loop sooner or later +-- Build-Depends: midi + Hs-source-dirs: src, test + GHC-Options: -Wall + Main-Is: Main.hs diff --git a/src/Sound/MIDI/Event.hs b/src/Sound/MIDI/Event.hs deleted file mode 100644 --- a/src/Sound/MIDI/Event.hs +++ /dev/null @@ -1,552 +0,0 @@ -{- | -Datatype for MIDI events as they can be sent to a synthesizer. -That is, no timing is handled here. - -Taken from Haskore. --} - -module Sound.MIDI.Event( - T(..), - Pitch, Program, - Channel, Controller(..), ControllerValue, PitchBendRange, Pressure, Velocity, - isNote, isNoteOn, isNoteOff, zeroKey, - maximumVelocity, normalVelocity, toFloatVelocity, - toFloatController, - - bankSelect, modulation, breathControl, footControl, portamentoTime, - dataEntry, mainVolume, balance, panorama, expression, - generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, - vectorX, vectorY, - - bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, - portamentoTimeMSB, dataEntryMSB, mainVolumeMSB, balanceMSB, - panoramaMSB, expressionMSB, generalPurpose1MSB, generalPurpose2MSB, - generalPurpose3MSB, generalPurpose4MSB, bankSelectLSB, modulationLSB, - breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, - mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB, - generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB, - - sustain, porta, sustenuto, softPedal, hold2, - generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, - extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth, - - dataIncrement, dataDecrement, - nonRegisteredParameterLSB, nonRegisteredParameterMSB, - registeredParameterLSB, registeredParameterMSB, - - fromPitch, toPitch, - fromVelocity, toVelocity, - fromProgram, toProgram, - fromChannel, toChannel, - increasePitch, subtractPitch, - ) where - -import Data.Ix (Ix) - - - -{- * MIDI Events -} - -newtype Pitch = Pitch {fromPitch :: Int} deriving (Show, Eq, Ord, Ix) -newtype Velocity = Velocity {fromVelocity :: Int} deriving (Show, Eq, Ord) -newtype Program = Program {fromProgram :: Int} deriving (Show, Eq, Ord, Ix) -newtype Channel = Channel {fromChannel :: Int} deriving (Show, Eq, Ord, Ix) - -toPitch :: Int -> Pitch -toPitch = checkRange "Pitch" Pitch - -toVelocity :: Int -> Velocity -toVelocity = checkRange "Velocity" Velocity - -toProgram :: Int -> Program -toProgram = checkRange "Program" Program - -toChannel :: Int -> Channel -toChannel = checkRange "Channel" Channel - -checkRange :: (Bounded a, Ord a, Show a) => - String -> (Int -> a) -> Int -> a -checkRange typ f x = - let y = f x - in if minBound <= y && y <= maxBound - then y - else error (typ ++ ": value " ++ show x ++ " outside range " ++ - show ((minBound, maxBound) `asTypeOf` (y,y))) - -instance Enum Program where - toEnum = toProgram - fromEnum = fromProgram - -instance Enum Channel where - toEnum = toChannel - fromEnum = fromChannel - -instance Enum Pitch where - toEnum = toPitch - fromEnum = fromPitch - --- typical methods of a type class for affine spaces -increasePitch :: Int -> Pitch -> Pitch -increasePitch d = toPitch . (d+) . fromPitch - -subtractPitch :: Pitch -> Pitch -> Int -subtractPitch (Pitch p0) (Pitch p1) = p1-p0 - - -instance Bounded Pitch where - minBound = Pitch 0 - maxBound = Pitch 127 - -instance Bounded Velocity where - minBound = Velocity 0 - maxBound = Velocity 127 - -instance Bounded Program where - minBound = Program 0 - maxBound = Program 127 - -instance Bounded Channel where - minBound = Channel 0 - maxBound = Channel 15 - - -{- | -A MIDI problem is that one cannot uniquely map -a MIDI key to a frequency. -The frequency depends on the instrument. -I don't know if the deviations are defined for General MIDI. -If this applies one could add transposition information -to the use patch map. -For now I have chosen a value that leads to the right frequency -for some piano sound in my setup. --} - -zeroKey :: Pitch -zeroKey = toPitch 48 - -{- | -The velocity of an ordinary key stroke and -the maximum possible velocity. --} - -normalVelocity, maximumVelocity :: Num quant => quant - -- Velocity -normalVelocity = 64 -maximumVelocity = 127 - -{- | -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. --} -toFloatVelocity :: (Integral a, Fractional b) => a -> b -toFloatVelocity x = fromIntegral x / normalVelocity - -maximumControllerValue :: Num quant => quant -maximumControllerValue = 127 - -{- | -Map integral MIDI controller value to floating point value. -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 - - - -type PitchBendRange = Int -type Pressure = Int -type ControllerValue = Int - -data T = - NoteOff Pitch Velocity - | NoteOn Pitch Velocity - | PolyAfter Pitch Pressure - | ProgramChange Program - | Control Controller ControllerValue - | PitchBend PitchBendRange - | MonoAfter Pressure - deriving (Show, Eq, Ord) - - -isNote :: T -> Bool -isNote (NoteOn _ _) = True -isNote (NoteOff _ _) = True -isNote _ = False - -isNoteOn :: T -> Bool -isNoteOn (NoteOn _ _) = True -isNoteOn _ = False - -isNoteOff :: T -> Bool -isNoteOff (NoteOff _ _) = True -isNoteOff _ = False - - - -{-# DEPRECATED BankSelectMSB "use bankSelectMSB instead" #-} -{-# DEPRECATED ModulationMSB "use modulationMSB instead" #-} -{-# DEPRECATED BreathControlMSB "use breathControlMSB instead" #-} -{-# DEPRECATED Controller03 "use toEnum 0x03 instead" #-} -{-# DEPRECATED FootControlMSB "use footControlMSB instead" #-} -{-# DEPRECATED PortamentoTimeMSB "use portamentoTimeMSB instead" #-} -{-# DEPRECATED DataEntryMSB "use dataEntryMSB instead" #-} -{-# DEPRECATED MainVolumeMSB "use mainVolumeMSB instead" #-} -{-# DEPRECATED BalanceMSB "use balanceMSB instead" #-} -{-# DEPRECATED Controller09 "use toEnum 0x09 instead" #-} -{-# DEPRECATED PanoramaMSB "use panoramaMSB instead" #-} -{-# DEPRECATED ExpressionMSB "use expressionMSB instead" #-} -{-# DEPRECATED Controller0C "use toEnum 0x0C instead" #-} -{-# DEPRECATED Controller0D "use toEnum 0x0D instead" #-} -{-# DEPRECATED Controller0E "use toEnum 0x0E instead" #-} -{-# DEPRECATED Controller0F "use toEnum 0x0F instead" #-} -{-# DEPRECATED GeneralPurpose1MSB "use generalPurpose1MSB instead" #-} -{-# DEPRECATED GeneralPurpose2MSB "use generalPurpose2MSB instead" #-} -{-# DEPRECATED GeneralPurpose3MSB "use generalPurpose3MSB instead" #-} -{-# DEPRECATED GeneralPurpose4MSB "use generalPurpose4MSB instead" #-} -{-# DEPRECATED Controller14 "use toEnum 0x14 instead" #-} -{-# DEPRECATED Controller15 "use toEnum 0x15 instead" #-} -{-# DEPRECATED Controller16 "use toEnum 0x16 instead" #-} -{-# DEPRECATED Controller17 "use toEnum 0x17 instead" #-} -{-# DEPRECATED Controller18 "use toEnum 0x18 instead" #-} -{-# DEPRECATED Controller19 "use toEnum 0x19 instead" #-} -{-# DEPRECATED Controller1A "use toEnum 0x1A instead" #-} -{-# DEPRECATED Controller1B "use toEnum 0x1B instead" #-} -{-# DEPRECATED Controller1C "use toEnum 0x1C instead" #-} -{-# DEPRECATED Controller1D "use toEnum 0x1D instead" #-} -{-# DEPRECATED Controller1E "use toEnum 0x1E instead" #-} -{-# DEPRECATED Controller1F "use toEnum 0x1F instead" #-} -{-# DEPRECATED BankSelectLSB "use bankSelectLSB instead" #-} -{-# DEPRECATED ModulationLSB "use modulationLSB instead" #-} -{-# DEPRECATED BreathControlLSB "use breathControlLSB instead" #-} -{-# DEPRECATED Controller23 "use toEnum 0x23 instead" #-} -{-# DEPRECATED FootControlLSB "use footControlLSB instead" #-} -{-# DEPRECATED PortamentoTimeLSB "use portamentoTimeLSB instead" #-} -{-# DEPRECATED DataEntryLSB "use dataEntryLSB instead" #-} -{-# DEPRECATED MainVolumeLSB "use mainVolumeLSB instead" #-} -{-# DEPRECATED BalanceLSB "use balanceLSB instead" #-} -{-# DEPRECATED Controller29 "use toEnum 0x29 instead" #-} -{-# DEPRECATED PanoramaLSB "use panoramaLSB instead" #-} -{-# DEPRECATED ExpressionLSB "use expressionLSB instead" #-} -{-# DEPRECATED Controller2C "use toEnum 0x2C instead" #-} -{-# DEPRECATED Controller2D "use toEnum 0x2D instead" #-} -{-# DEPRECATED Controller2E "use toEnum 0x2E instead" #-} -{-# DEPRECATED Controller2F "use toEnum 0x2F instead" #-} -{-# DEPRECATED GeneralPurpose1LSB "use generalPurpose1LSB instead" #-} -{-# DEPRECATED GeneralPurpose2LSB "use generalPurpose2LSB instead" #-} -{-# DEPRECATED GeneralPurpose3LSB "use generalPurpose3LSB instead" #-} -{-# DEPRECATED GeneralPurpose4LSB "use generalPurpose4LSB instead" #-} -{-# DEPRECATED Controller34 "use toEnum 0x34 instead" #-} -{-# DEPRECATED Controller35 "use toEnum 0x35 instead" #-} -{-# DEPRECATED Controller36 "use toEnum 0x36 instead" #-} -{-# DEPRECATED Controller37 "use toEnum 0x37 instead" #-} -{-# DEPRECATED Controller38 "use toEnum 0x38 instead" #-} -{-# DEPRECATED Controller39 "use toEnum 0x39 instead" #-} -{-# DEPRECATED Controller3A "use toEnum 0x3A instead" #-} -{-# DEPRECATED Controller3B "use toEnum 0x3B instead" #-} -{-# DEPRECATED Controller3C "use toEnum 0x3C instead" #-} -{-# DEPRECATED Controller3D "use toEnum 0x3D instead" #-} -{-# DEPRECATED Controller3E "use toEnum 0x3E instead" #-} -{-# DEPRECATED Controller3F "use toEnum 0x3F instead" #-} - -{-# DEPRECATED Sustain "use sustain instead" #-} -{-# DEPRECATED Porta "use porta instead" #-} -{-# DEPRECATED Sustenuto "use sustenuto instead" #-} -{-# DEPRECATED SoftPedal "use softPedal instead" #-} -{-# DEPRECATED Controller44 "use toEnum 0x44 instead" #-} -{-# DEPRECATED Hold2 "use hold2 instead" #-} -{-# DEPRECATED Controller46 "use toEnum 0x46 instead" #-} -{-# DEPRECATED Controller47 "use toEnum 0x47 instead" #-} -{-# DEPRECATED Controller48 "use toEnum 0x48 instead" #-} -{-# DEPRECATED Controller49 "use toEnum 0x49 instead" #-} -{-# DEPRECATED Controller4A "use toEnum 0x4A instead" #-} -{-# DEPRECATED Controller4B "use toEnum 0x4B instead" #-} -{-# DEPRECATED Controller4C "use toEnum 0x4C instead" #-} -{-# DEPRECATED Controller4D "use toEnum 0x4D instead" #-} -{-# DEPRECATED Controller4E "use toEnum 0x4E instead" #-} -{-# DEPRECATED Controller4F "use toEnum 0x4F instead" #-} -{-# DEPRECATED GeneralPurpose5 "use generalPurpose5 instead" #-} -{-# DEPRECATED GeneralPurpose6 "use generalPurpose6 instead" #-} -{-# DEPRECATED GeneralPurpose7 "use generalPurpose7 instead" #-} -{-# DEPRECATED GeneralPurpose8 "use generalPurpose8 instead" #-} -{-# DEPRECATED Controller54 "use toEnum 0x54 instead" #-} -{-# DEPRECATED Controller55 "use toEnum 0x55 instead" #-} -{-# DEPRECATED Controller56 "use toEnum 0x56 instead" #-} -{-# DEPRECATED Controller57 "use toEnum 0x57 instead" #-} -{-# DEPRECATED Controller58 "use toEnum 0x58 instead" #-} -{-# DEPRECATED Controller59 "use toEnum 0x59 instead" #-} -{-# DEPRECATED Controller5A "use toEnum 0x5A instead" #-} -{-# DEPRECATED ExtDepth "use extDepth instead" #-} -{-# DEPRECATED TremoloDepth "use tremoloDepth instead" #-} -{-# DEPRECATED ChorusDepth "use chorusDepth instead" #-} -{-# DEPRECATED CelesteDepth "use celesteDepth instead" #-} -{-# DEPRECATED PhaserDepth "use phaserDepth instead" #-} - -{-# DEPRECATED DataIncrement "use dataIncrement instead" #-} -{-# DEPRECATED DataDecrement "use dataDecrement instead" #-} -{-# DEPRECATED NonRegisteredParameterLSB "use nonRegisteredParameterLSB instead" #-} -{-# DEPRECATED NonRegisteredParameterMSB "use nonRegisteredParameterMSB instead" #-} -{-# DEPRECATED RegisteredParameterLSB "use registeredParameterLSB instead" #-} -{-# DEPRECATED RegisteredParameterMSB "use registeredParameterMSB instead" #-} -{-# DEPRECATED Controller66 "use toEnum 0x66 instead" #-} -{-# DEPRECATED Controller67 "use toEnum 0x67 instead" #-} -{-# DEPRECATED Controller68 "use toEnum 0x68 instead" #-} -{-# DEPRECATED Controller69 "use toEnum 0x69 instead" #-} -{-# DEPRECATED Controller6A "use toEnum 0x6A instead" #-} -{-# DEPRECATED Controller6B "use toEnum 0x6B instead" #-} -{-# DEPRECATED Controller6C "use toEnum 0x6C instead" #-} -{-# DEPRECATED Controller6D "use toEnum 0x6D instead" #-} -{-# DEPRECATED Controller6E "use toEnum 0x6E instead" #-} -{-# DEPRECATED Controller6F "use toEnum 0x6F instead" #-} -{-# DEPRECATED Controller70 "use toEnum 0x70 instead" #-} -{-# DEPRECATED Controller71 "use toEnum 0x71 instead" #-} -{-# DEPRECATED Controller72 "use toEnum 0x72 instead" #-} -{-# DEPRECATED Controller73 "use toEnum 0x73 instead" #-} -{-# DEPRECATED Controller74 "use toEnum 0x74 instead" #-} -{-# DEPRECATED Controller75 "use toEnum 0x75 instead" #-} -{-# DEPRECATED Controller76 "use toEnum 0x76 instead" #-} -{-# DEPRECATED Controller77 "use toEnum 0x77 instead" #-} -{-# DEPRECATED Controller78 "use toEnum 0x78 instead" #-} -{-# DEPRECATED Controller79 "use toEnum 0x79 instead" #-} -{-# DEPRECATED Controller7A "use toEnum 0x7A instead" #-} -{-# DEPRECATED Controller7B "use toEnum 0x7B instead" #-} -{-# DEPRECATED Controller7C "use toEnum 0x7C instead" #-} -{-# DEPRECATED Controller7D "use toEnum 0x7D instead" #-} -{-# DEPRECATED Controller7E "use toEnum 0x7E instead" #-} -{-# DEPRECATED Controller7F "use toEnum 0x7F instead" #-} - - -{- | -Types of predefined MIDI controllers. --} -data Controller = - {- 00 00 -} BankSelectMSB - | {- 01 01 -} ModulationMSB - | {- 02 02 -} BreathControlMSB - | {- 03 03 -} Controller03 - | {- 04 04 -} FootControlMSB - | {- 05 05 -} PortamentoTimeMSB - | {- 06 06 -} DataEntryMSB - | {- 07 07 -} MainVolumeMSB - | {- 08 08 -} BalanceMSB - | {- 09 09 -} Controller09 - | {- 10 0A -} PanoramaMSB - | {- 11 0B -} ExpressionMSB - | {- 12 0C -} Controller0C - | {- 13 0D -} Controller0D - | {- 14 0E -} Controller0E - | {- 15 0F -} Controller0F - | {- 16 10 -} GeneralPurpose1MSB - | {- 17 11 -} GeneralPurpose2MSB - | {- 18 12 -} GeneralPurpose3MSB - | {- 19 13 -} GeneralPurpose4MSB - | {- 20 14 -} Controller14 - | {- 21 15 -} Controller15 - | {- 22 16 -} Controller16 - | {- 23 17 -} Controller17 - | {- 24 18 -} Controller18 - | {- 25 19 -} Controller19 - | {- 26 1A -} Controller1A - | {- 27 1B -} Controller1B - | {- 28 1C -} Controller1C - | {- 29 1D -} Controller1D - | {- 30 1E -} Controller1E - | {- 31 1F -} Controller1F - | {- 32 20 -} BankSelectLSB - | {- 33 21 -} ModulationLSB - | {- 34 22 -} BreathControlLSB - | {- 35 23 -} Controller23 - | {- 36 24 -} FootControlLSB - | {- 37 25 -} PortamentoTimeLSB - | {- 38 26 -} DataEntryLSB - | {- 39 27 -} MainVolumeLSB - | {- 40 28 -} BalanceLSB - | {- 41 29 -} Controller29 - | {- 42 2A -} PanoramaLSB - | {- 43 2B -} ExpressionLSB - | {- 44 2C -} Controller2C - | {- 45 2D -} Controller2D - | {- 46 2E -} Controller2E - | {- 47 2F -} Controller2F - | {- 48 30 -} GeneralPurpose1LSB - | {- 49 31 -} GeneralPurpose2LSB - | {- 50 32 -} GeneralPurpose3LSB - | {- 51 33 -} GeneralPurpose4LSB - | {- 52 34 -} Controller34 - | {- 53 35 -} Controller35 - | {- 54 36 -} Controller36 - | {- 55 37 -} Controller37 - | {- 56 38 -} Controller38 - | {- 57 39 -} Controller39 - | {- 58 3A -} Controller3A - | {- 59 3B -} Controller3B - | {- 60 3C -} Controller3C - | {- 61 3D -} Controller3D - | {- 62 3E -} Controller3E - | {- 63 3F -} Controller3F - {- Continuous 7 bit (switches: 0-3f=off, 40-7f=on) -} - | {- 64 40 -} Sustain - | {- 65 41 -} Porta - | {- 66 42 -} Sustenuto - | {- 67 43 -} SoftPedal - | {- 68 44 -} Controller44 - | {- 69 45 -} Hold2 - | {- 70 46 -} Controller46 - | {- 71 47 -} Controller47 - | {- 72 48 -} Controller48 - | {- 73 49 -} Controller49 - | {- 74 4A -} Controller4A - | {- 75 4B -} Controller4B - | {- 76 4C -} Controller4C - | {- 77 4D -} Controller4D - | {- 78 4E -} Controller4E - | {- 79 4F -} Controller4F - | {- 80 50 -} GeneralPurpose5 - | {- 81 51 -} GeneralPurpose6 - | {- 82 52 -} GeneralPurpose7 - | {- 83 53 -} GeneralPurpose8 - | {- 84 54 -} Controller54 - | {- 85 55 -} Controller55 - | {- 86 56 -} Controller56 - | {- 87 57 -} Controller57 - | {- 88 58 -} Controller58 - | {- 89 59 -} Controller59 - | {- 90 5A -} Controller5A - | {- 91 5B -} ExtDepth - | {- 92 5C -} TremoloDepth - | {- 93 5D -} ChorusDepth - | {- 94 5E -} CelesteDepth - | {- 95 5F -} PhaserDepth - {- Parameters -} - | {- 96 60 -} DataIncrement - | {- 97 61 -} DataDecrement - | {- 98 62 -} NonRegisteredParameterLSB - | {- 99 63 -} NonRegisteredParameterMSB - | {- 100 64 -} RegisteredParameterLSB - | {- 101 65 -} RegisteredParameterMSB - | {- 102 66 -} Controller66 - | {- 103 67 -} Controller67 - | {- 104 68 -} Controller68 - | {- 105 69 -} Controller69 - | {- 106 6A -} Controller6A - | {- 107 6B -} Controller6B - | {- 108 6C -} Controller6C - | {- 109 6D -} Controller6D - | {- 110 6E -} Controller6E - | {- 111 6F -} Controller6F - | {- 112 70 -} Controller70 - | {- 113 71 -} Controller71 - | {- 114 72 -} Controller72 - | {- 115 73 -} Controller73 - | {- 116 74 -} Controller74 - | {- 117 75 -} Controller75 - | {- 118 76 -} Controller76 - | {- 119 77 -} Controller77 - | {- 120 78 -} Controller78 - | {- 121 79 -} Controller79 - | {- 122 7A -} Controller7A - | {- 123 7B -} Controller7B - | {- 124 7C -} Controller7C - | {- 125 7D -} Controller7D - | {- 126 7E -} Controller7E - | {- 127 7F -} Controller7F - deriving (Show, Eq, Ord, Enum) - - - - - - -bankSelect, modulation, breathControl, footControl, portamentoTime, - dataEntry, mainVolume, balance, panorama, expression, - generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, - vectorX, vectorY :: Controller -bankSelect = bankSelectMSB -modulation = modulationMSB -breathControl = breathControlMSB -footControl = footControlMSB -portamentoTime = portamentoTimeMSB -dataEntry = dataEntryMSB -mainVolume = mainVolumeMSB -balance = balanceMSB -panorama = panoramaMSB -expression = expressionMSB -generalPurpose1 = generalPurpose1MSB -generalPurpose2 = generalPurpose2MSB -generalPurpose3 = generalPurpose3MSB -generalPurpose4 = generalPurpose4MSB - -vectorX = generalPurpose1 -vectorY = generalPurpose2 - - - -bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, - portamentoTimeMSB, dataEntryMSB, mainVolumeMSB, balanceMSB, - panoramaMSB, expressionMSB, generalPurpose1MSB, generalPurpose2MSB, - generalPurpose3MSB, generalPurpose4MSB, bankSelectLSB, modulationLSB, - breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, - mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB, - generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB :: Controller - -sustain, porta, sustenuto, softPedal, hold2, - generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, - extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth :: Controller - -dataIncrement, dataDecrement, - nonRegisteredParameterLSB, nonRegisteredParameterMSB, - registeredParameterLSB, registeredParameterMSB :: Controller - - -bankSelectMSB = BankSelectMSB {- 00 00 -} -modulationMSB = ModulationMSB {- 01 01 -} -breathControlMSB = BreathControlMSB {- 02 02 -} -footControlMSB = FootControlMSB {- 04 04 -} -portamentoTimeMSB = PortamentoTimeMSB {- 05 05 -} -dataEntryMSB = DataEntryMSB {- 06 06 -} -mainVolumeMSB = MainVolumeMSB {- 07 07 -} -balanceMSB = BalanceMSB {- 08 08 -} -panoramaMSB = PanoramaMSB {- 10 0A -} -expressionMSB = ExpressionMSB {- 11 0B -} -generalPurpose1MSB = GeneralPurpose1MSB {- 16 10 -} -generalPurpose2MSB = GeneralPurpose2MSB {- 17 11 -} -generalPurpose3MSB = GeneralPurpose3MSB {- 18 12 -} -generalPurpose4MSB = GeneralPurpose4MSB {- 19 13 -} -bankSelectLSB = BankSelectLSB {- 32 20 -} -modulationLSB = ModulationLSB {- 33 21 -} -breathControlLSB = BreathControlLSB {- 34 22 -} -footControlLSB = FootControlLSB {- 36 24 -} -portamentoTimeLSB = PortamentoTimeLSB {- 37 25 -} -dataEntryLSB = DataEntryLSB {- 38 26 -} -mainVolumeLSB = MainVolumeLSB {- 39 27 -} -balanceLSB = BalanceLSB {- 40 28 -} -panoramaLSB = PanoramaLSB {- 42 2A -} -expressionLSB = ExpressionLSB {- 43 2B -} -generalPurpose1LSB = GeneralPurpose1LSB {- 48 30 -} -generalPurpose2LSB = GeneralPurpose2LSB {- 49 31 -} -generalPurpose3LSB = GeneralPurpose3LSB {- 50 32 -} -generalPurpose4LSB = GeneralPurpose4LSB {- 51 33 -} - -sustain = Sustain {- 64 40 -} -porta = Porta {- 65 41 -} -sustenuto = Sustenuto {- 66 42 -} -softPedal = SoftPedal {- 67 43 -} -hold2 = Hold2 {- 69 45 -} -generalPurpose5 = GeneralPurpose5 {- 80 50 -} -generalPurpose6 = GeneralPurpose6 {- 81 51 -} -generalPurpose7 = GeneralPurpose7 {- 82 52 -} -generalPurpose8 = GeneralPurpose8 {- 83 53 -} -extDepth = ExtDepth {- 91 5B -} -tremoloDepth = TremoloDepth {- 92 5C -} -chorusDepth = ChorusDepth {- 93 5D -} -celesteDepth = CelesteDepth {- 94 5E -} -phaserDepth = PhaserDepth {- 95 5F -} - -dataIncrement = DataIncrement {- 96 60 -} -dataDecrement = DataDecrement {- 97 61 -} -nonRegisteredParameterLSB = NonRegisteredParameterLSB {- 98 62 -} -nonRegisteredParameterMSB = NonRegisteredParameterMSB {- 99 63 -} -registeredParameterLSB = RegisteredParameterLSB {- 100 64 -} -registeredParameterMSB = RegisteredParameterMSB {- 101 65 -} diff --git a/src/Sound/MIDI/File.hs b/src/Sound/MIDI/File.hs --- a/src/Sound/MIDI/File.hs +++ b/src/Sound/MIDI/File.hs @@ -6,25 +6,35 @@ module Sound.MIDI.File( T(..), Division(..), Track, Type(..), - SchedEvent, Event(..), ElapsedTime, - Tempo, SMPTEHours, SMPTEMins, SMPTESecs, SMPTEFrames, SMPTEBits, - MetaEvent(..), - maybeMIDIEvent, maybeMetaEvent, - Key(..), Mode(..), - defltST, defltDurT, empty, + empty, + ElapsedTime, fromElapsedTime, toElapsedTime, + Tempo, fromTempo, toTempo, + explicitNoteOff, implicitNoteOff, showLines, changeVelocity, getTracks, resampleTime, showEvent, showTime, sortEvents, progChangeBeforeSetTempo, ) where -import qualified Sound.MIDI.Event as MIDIEvent --- import Sound.MIDI.Event (T(NoteOn, NoteOff)) +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.File.Event.Meta as MetaEvent +import qualified Sound.MIDI.File.Event as Event +import Sound.MIDI.File.Event.Meta ( + ElapsedTime, fromElapsedTime, toElapsedTime, + Tempo, fromTempo, toTempo, + ) + + import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Numeric.NonNegative.Wrapper as NonNeg +-- import qualified Numeric.NonNegative.Wrapper as NonNeg -import Sound.MIDI.IO(ByteString) -import Sound.MIDI.String (rightS, concatS) +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC + +import Control.Monad (liftM, liftM2, ) +-- import Sound.MIDI.IO(ByteList) +import Sound.MIDI.String (rightS, ) import Data.Ix(Ix) import Data.List(groupBy, sort) import Data.Maybe(fromMaybe) @@ -36,99 +46,78 @@ data T = Cons Type Division [Track] deriving (Show, Eq) data Type = Mixed | Parallel | Serial - deriving (Show,Eq,Enum) + deriving (Show, Eq, Ord, Ix, Enum, Bounded) data Division = Ticks Tempo | SMPTE Int Int - deriving (Show,Eq) + deriving (Show, Eq) -type Track = EventList.T ElapsedTime Event -type SchedEvent = (ElapsedTime, Event) -type ElapsedTime = NonNeg.Integer +type Track = EventList.T ElapsedTime Event.T -data Event = - MIDIEvent MIDIEvent.Channel MIDIEvent.T - | MetaEvent MetaEvent - | SysExStart ByteString -- F0 - | SysExCont ByteString -- F7 - deriving (Show,Eq,Ord) +{- | +An empty MIDI file. +-} -maybeMIDIEvent :: Event -> Maybe (MIDIEvent.Channel, MIDIEvent.T) -maybeMIDIEvent (MIDIEvent ch ev) = Just (ch,ev) -maybeMIDIEvent _ = Nothing +empty :: T +empty = Cons Mixed (Ticks 0) [EventList.empty] -maybeMetaEvent :: Event -> Maybe MetaEvent -maybeMetaEvent (MetaEvent mev) = Just mev -maybeMetaEvent _ = Nothing +instance Arbitrary T where + arbitrary = + do (typ, content) <- + QC.oneof $ + fmap (\track -> (Mixed, [track])) arbitrary : + fmap (\tracks -> (Parallel, tracks)) arbitrary : + fmap (\tracks -> (Serial, tracks)) arbitrary : + [] + division <- arbitrary + return (Cons typ division content) + coarbitrary = error "not implemented" -{- * Meta Events -} +instance Arbitrary Division where + arbitrary = + QC.oneof $ + liftM (Ticks . (1+)) arbitrary : + liftM2 (\x y -> SMPTE (1+abs x) (1+abs y)) arbitrary arbitrary : + [] + coarbitrary = error "not implemented" -type Tempo = NonNeg.Int -type SMPTEHours = Int -type SMPTEMins = Int -type SMPTESecs = Int -type SMPTEFrames = Int -type SMPTEBits = Int -data MetaEvent = - SequenceNum Int - | TextEvent String - | Copyright String - | TrackName String - | InstrName String - | Lyric String - | Marker String - | CuePoint String - | MIDIPrefix MIDIEvent.Channel - | EndOfTrack - | SetTempo Tempo - | SMPTEOffset SMPTEHours SMPTEMins SMPTESecs SMPTEFrames SMPTEBits - | TimeSig Int Int Int Int - | KeySig Key Mode - | SequencerSpecific ByteString - | Unknown Int ByteString - deriving (Show, Eq, Ord) -{- | -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) +{- * Processing -} {- | -The Key Signature specifies a mode, either major or minor. +Apply a function to each track. -} - -data Mode = Major | Minor - deriving (Show, Eq, Ord, Enum) +mapTrack :: (Track -> Track) -> T -> T +mapTrack f (Cons mfType division tracks) = + Cons mfType division (map f tracks) {- | -Default duration of a whole note, in seconds; and the default SetTempo -value, in microseconds per quarter note. Both express the default of -120 beats per minute. +Convert all @NoteOn p 0@ to @NoteOff p 64@. +The latter one is easier to process. -} +explicitNoteOff :: T -> T +explicitNoteOff = + mapTrack (EventList.mapBody (Event.mapVoice VoiceMsg.explicitNoteOff)) -defltDurT :: ElapsedTime -defltDurT = 2 -defltST :: Tempo -defltST = div 1000000 (fromIntegral defltDurT) {- | -An empty MIDI file. +Convert all @NoteOff p 64@ to @NoteOn p 0@. +The latter one can be encoded more efficiently using the running status. -} - -empty :: T -empty = Cons Mixed (Ticks 0) [EventList.empty] +implicitNoteOff :: T -> T +implicitNoteOff = + mapTrack (EventList.mapBody (Event.mapVoice VoiceMsg.implicitNoteOff)) {- * Debugging -} +{-# DEPRECATED + showLines, changeVelocity, getTracks, resampleTime, + showEvent, showTime, + sortEvents, progChangeBeforeSetTempo + "only use this for debugging" #-} + {- | Show the 'T' with one event per line, suited for comparing MIDIFiles with @diff@. @@ -152,15 +141,13 @@ showTime t = rightS 10 (shows t) . showString " : " -showEvent :: Event -> ShowS -showEvent (MIDIEvent ch e) = - showString "MIDIEvent " . shows ch . showString " " . shows e -showEvent (MetaEvent e) = - showString "MetaEvent " . shows e -showEvent (SysExStart s) = - showString "SysExStart " . concatS (map shows s) -showEvent (SysExCont s) = - showString "SysExCont " . concatS (map shows s) +showEvent :: Event.T -> ShowS +showEvent (Event.MIDIEvent e) = + showString "Event.MIDIEvent " . shows e +showEvent (Event.MetaEvent e) = + showString "Event.MetaEvent " . shows e +showEvent (Event.SystemExclusive s) = + showString "SystemExclusive " . shows s {- | @@ -168,31 +155,29 @@ -} changeVelocity :: Double -> T -> T -changeVelocity r (Cons mfType division tracks) = - let multVel vel = MIDIEvent.toVelocity $ - round (r * fromIntegral (MIDIEvent.fromVelocity vel)) - procMIDIEvent (MIDIEvent.NoteOn pitch vel) = MIDIEvent.NoteOn pitch (multVel vel) - procMIDIEvent (MIDIEvent.NoteOff pitch vel) = MIDIEvent.NoteOff pitch (multVel vel) - procMIDIEvent me = me - procEvent (MIDIEvent chan ev) = MIDIEvent chan (procMIDIEvent ev) - procEvent ev = ev - in Cons mfType division (map (EventList.mapBody procEvent) tracks) +changeVelocity r = + let multVel vel = + VoiceMsg.toVelocity $ + round (r * fromIntegral (VoiceMsg.fromVelocity vel)) + procVoice (VoiceMsg.NoteOn pitch vel) = VoiceMsg.NoteOn pitch (multVel vel) + procVoice (VoiceMsg.NoteOff pitch vel) = VoiceMsg.NoteOff pitch (multVel vel) + procVoice me = me + in mapTrack (EventList.mapBody (Event.mapVoice procVoice)) {- | Change the time base. -} resampleTime :: Double -> T -> T -resampleTime r (Cons mfType division tracks) = +resampleTime r = let divTime time = round (fromIntegral time / r) newTempo tmp = round (fromIntegral tmp * r) procEvent ev = case ev of - MetaEvent (SetTempo tmp) -> - MetaEvent (SetTempo (newTempo tmp)) + Event.MetaEvent (MetaEvent.SetTempo tmp) -> + Event.MetaEvent (MetaEvent.SetTempo (newTempo tmp)) _ -> ev - in Cons mfType division - (map (EventList.mapBody procEvent . EventList.mapTime divTime) tracks) + in mapTrack (EventList.mapBody procEvent . EventList.mapTime divTime) getTracks :: T -> [Track] getTracks (Cons _ _ trks) = trks @@ -209,35 +194,44 @@ -} sortEvents :: T -> T -sortEvents (Cons mfType division tracks) = - let coincideNote (MIDIEvent _ x0) (MIDIEvent _ x1) = - MIDIEvent.isNote x0 && MIDIEvent.isNote x1 +sortEvents = + let coincideNote ev0 ev1 = + fromMaybe False $ + do (_,x0) <- Event.maybeVoice ev0 + (_,x1) <- Event.maybeVoice ev1 + return (VoiceMsg.isNote x0 && VoiceMsg.isNote x1) +{- + coincideNote + (Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice x0))) + (Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice x1))) = + VoiceMsg.isNote x0 && VoiceMsg.isNote x1 coincideNote _ _ = False +-} sortTrack = EventList.flatten . EventList.mapBody sort . EventList.mapCoincident (groupBy coincideNote) - in Cons mfType division (map sortTrack tracks) + in mapTrack sortTrack {- | Old versions of "Haskore.Interface.MIDI.Write" -wrote 'MIDIEvent.ProgramChange' and 'SetTempo' +wrote 'MIDIEvent.ProgramChange' and 'MetaEvent.SetTempo' once at the beginning of a file in that order. The current version supports multiple 'MIDIEvent.ProgramChange's in a track and thus a 'MIDIEvent.ProgramChange' is set immediately before a note. -Because of this a 'MIDIEvent.ProgramChange' is now always after a 'SetTempo'. +Because of this a 'MIDIEvent.ProgramChange' is now always after a 'MetaEvent.SetTempo'. For checking equivalence with old MIDI files we can switch this back. -} progChangeBeforeSetTempo :: T -> T -progChangeBeforeSetTempo (Cons mfType division tracks) = +progChangeBeforeSetTempo = let sortTrack evs = - do ((t0,st@(MetaEvent (SetTempo _))), rest0) + do ((t0,st@(Event.MetaEvent (MetaEvent.SetTempo _))), rest0) <- EventList.viewL evs - ((t1,pc@(MIDIEvent _ (MIDIEvent.ProgramChange _))), rest1) + ((t1,pc@(Event.MIDIEvent (ChannelMsg.Cons _ + (ChannelMsg.Voice (VoiceMsg.ProgramChange _))))), rest1) <- EventList.viewL rest0 return $ EventList.cons t0 pc $ EventList.cons 0 st $ EventList.delay t1 rest1 - in Cons mfType division - (map (\track -> fromMaybe track (sortTrack track)) tracks) + in mapTrack (\track -> fromMaybe track (sortTrack track)) diff --git a/src/Sound/MIDI/File/Event.hs b/src/Sound/MIDI/File/Event.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/File/Event.hs @@ -0,0 +1,118 @@ +{- | +MIDI messages in MIDI files. +They are not a superset of the messages, +that are used for real-time communication between MIDI devices. +For these refer to "Sound.MIDI.Message". +Namely System Common and System Real Time messages are missing. +If you need both real-time and file messages (say for ALSA sequencer), +you need a custom datatype. +-} +module Sound.MIDI.File.Event ( + T(..), get, put, + TrackEvent, getTrackEvent, + ElapsedTime, fromElapsedTime, toElapsedTime, + mapBody, maybeMIDIEvent, maybeMetaEvent, maybeVoice, mapVoice, + ) where + +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Channel.Voice as Voice +import qualified Sound.MIDI.File.Event.SystemExclusive as SysEx +import qualified Sound.MIDI.File.Event.Meta as MetaEvent + +import Sound.MIDI.Message.Channel (Channel) + +import Sound.MIDI.File.Event.Meta ( + ElapsedTime, fromElapsedTime, toElapsedTime, + ) + +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Status as StatusParser +import qualified Sound.MIDI.Parser.Class as Parser + +import Control.Monad.Trans (lift, ) +import Control.Monad (liftM, liftM2, ) + +import qualified Sound.MIDI.Writer.Status as StatusWriter +import qualified Sound.MIDI.Writer.Basic as Writer + +import Sound.MIDI.Utility (mapSnd) + + +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC + + + +type TrackEvent = (ElapsedTime, T) + +mapBody :: (T -> T) -> (TrackEvent -> TrackEvent) +mapBody = mapSnd + + +data T = + MIDIEvent ChannelMsg.T + | MetaEvent MetaEvent.T + | SystemExclusive SysEx.T + deriving (Show,Eq,Ord) + +instance Arbitrary T where + arbitrary = + QC.frequency $ + (100, liftM MIDIEvent arbitrary) : + ( 1, liftM MetaEvent arbitrary) : + [] + coarbitrary = error "not implemented" + + +maybeMIDIEvent :: T -> Maybe ChannelMsg.T +maybeMIDIEvent (MIDIEvent msg) = Just msg +maybeMIDIEvent _ = Nothing + +maybeMetaEvent :: T -> Maybe MetaEvent.T +maybeMetaEvent (MetaEvent mev) = Just mev +maybeMetaEvent _ = Nothing + +maybeVoice :: T -> Maybe (Channel, Voice.T) +maybeVoice (MIDIEvent (ChannelMsg.Cons ch (ChannelMsg.Voice ev))) = Just (ch,ev) +maybeVoice _ = Nothing + +mapVoice :: (Voice.T -> Voice.T) -> T -> T +mapVoice f (MIDIEvent (ChannelMsg.Cons ch (ChannelMsg.Voice ev))) = + MIDIEvent (ChannelMsg.Cons ch (ChannelMsg.Voice (f ev))) +mapVoice _ msg = msg + + +-- * serialization + +get :: Parser.C parser => StatusParser.T parser T +get = + StatusParser.lift get1 >>= \tag -> + if tag < 0xF0 + then liftM MIDIEvent $ ChannelMsg.getWithStatus tag + else + StatusParser.set Nothing >> + (StatusParser.lift $ + if tag == 0xFF + then liftM MetaEvent $ MetaEvent.get + else liftM SystemExclusive $ SysEx.get tag) + +{- | +Each event is preceded by the delta time: the time in ticks between the +last event and the current event. Parse a time and an event, ignoring +System Exclusive messages. +-} +getTrackEvent :: Parser.C parser => StatusParser.T parser TrackEvent +getTrackEvent = liftM2 (,) (StatusParser.lift getVar) get + + +{- | +The following functions encode various 'MIDIFile.T' elements +into the raw data of a standard MIDI file. +-} + +put :: Writer.C writer => T -> StatusWriter.T writer () +put e = + case e of + MIDIEvent m -> lift (ChannelMsg.put m) + MetaEvent m -> StatusWriter.clear >> lift (MetaEvent.put m) + SystemExclusive m -> StatusWriter.clear >> lift (SysEx.put m) diff --git a/src/Sound/MIDI/File/Event/Meta.hs b/src/Sound/MIDI/File/Event/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/File/Event/Meta.hs @@ -0,0 +1,258 @@ +module Sound.MIDI.File.Event.Meta ( + T(..), + Key(..), Scale(..), + ElapsedTime, fromElapsedTime, toElapsedTime, + Tempo, fromTempo, toTempo, + 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.Parser.Class as Parser +import qualified Sound.MIDI.Parser.Restricted as ParserRestricted + +import Control.Monad (liftM, liftM2, liftM4, liftM5, ) + +import qualified Sound.MIDI.Writer.Basic as Writer +import qualified Sound.MIDI.Bit as Bit + +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, ) + +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC +import System.Random (Random(random, randomR), ) + +import Prelude hiding (putStr, ) + + +{- * Meta Events -} + +type ElapsedTime = NonNeg.Integer +type Tempo = NonNeg.Int +type SMPTEHours = Int +type SMPTEMinutes = Int +type SMPTESeconds = Int +type SMPTEFrames = Int +type SMPTEBits = Int + +data T = + SequenceNum Int + | TextEvent String + | Copyright String + | TrackName String + | InstrumentName String + | Lyric String + | Marker String + | CuePoint String + | MIDIPrefix Channel + | EndOfTrack + | SetTempo Tempo + | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits + | TimeSig Int Int Int Int + | KeySig Key Scale + | SequencerSpecific ByteList + | Unknown Int ByteList + deriving (Show, Eq, Ord) + + +instance Arbitrary T where + arbitrary = + QC.oneof $ + liftM SequenceNum (QC.choose (0,0xFFFF)) : + liftM TextEvent arbitraryString : + liftM Copyright arbitraryString : + liftM TrackName arbitraryString : + liftM InstrumentName arbitraryString : + liftM Lyric arbitraryString : + liftM Marker arbitraryString : + liftM CuePoint arbitraryString : + liftM (MIDIPrefix . toChannel) (QC.choose (0,15)) : +-- return EndOfTrack : + 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 SequencerSpecific arbitraryByteList : +-- liftM Unknown arbitrary arbitraryByteList : + [] + coarbitrary = error "not implemented" + +arbitraryByte :: QC.Gen Int +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 + coarbitrary = error "not implemented" + + + +{- | +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 + coarbitrary = error "not implemented" + + + +{- | +Default duration of a whole note, in seconds; and the default SetTempo +value, in microseconds per quarter note. Both express the default of +120 beats per minute. +-} +defltDurT :: ElapsedTime +defltDurT = 2 +defltST :: Tempo +defltST = div 1000000 (fromIntegral defltDurT) + + +toElapsedTime :: Integer -> ElapsedTime +toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime" + +fromElapsedTime :: ElapsedTime -> Integer +fromElapsedTime = NonNeg.toNumber + + +toTempo :: Int -> Tempo +toTempo = NonNeg.fromNumberMsg "toTempo" + +fromTempo :: Tempo -> Int +fromTempo = NonNeg.toNumber + + + +-- * serialization + +get :: Parser.C parser => parser T +get = + do code <- get1 + len <- getVar + let parse = ParserRestricted.run len + let returnText cons = liftM (cons . listCharFromByte) $ getBigN len + case code of + 000 -> parse $ liftM SequenceNum get2 + 001 -> returnText TextEvent + 002 -> returnText Copyright + 003 -> returnText TrackName + 004 -> returnText InstrumentName + 005 -> returnText Lyric + 006 -> returnText Marker + 007 -> returnText CuePoint + + 032 -> parse $ + liftM (MIDIPrefix . toChannel) get1 + 047 -> return EndOfTrack + 081 -> parse $ + liftM (SetTempo . toTempo) get3 + + 084 -> parse $ + do {hrs <- get1 ; mins <- get1 ; secs <- get1; + frames <- get1 ; bits <- get1 ; + return (SMPTEOffset hrs mins secs frames bits)} + + 088 -> parse $ + do + n <- get1 + d <- get1 + c <- get1 + b <- get1 + return (TimeSig n d c b) + + 089 -> parse $ + do + sf <- get1 + sc <- getEnum + return (KeySig (toKeyName sf) sc) + + 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 >> + case ev of + SequenceNum num -> putInt 0 2 num + TextEvent s -> putStr 1 s + Copyright s -> putStr 2 s + TrackName s -> putStr 3 s + InstrumentName s -> putStr 4 s + Lyric s -> putStr 5 s + Marker s -> putStr 6 s + CuePoint s -> putStr 7 s + MIDIPrefix c -> putList 32 [fromChannel c] + EndOfTrack -> putList 47 [] + + SetTempo tp -> putInt 81 3 (fromTempo tp) + 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 + SequencerSpecific codes + -> putByteList 127 codes + Unknown typ s -> putByteList typ s + + +putByteList :: Writer.C writer => Int -> ByteList -> writer () +putByteList code bytes = + do + Writer.putIntAsByte code + Writer.putLenByteList bytes + +putInt :: Writer.C writer => Int -> Int -> Int -> writer () +putInt code numBytes x = + do + Writer.putIntAsByte code + Writer.putVar $ fromIntegral numBytes + Writer.putByteList $ + map fromIntegral $ Bit.someBytes numBytes x + +putStr :: Writer.C writer => Int -> String -> writer () +putStr code = + putByteList code . listByteFromChar + +putList :: Writer.C writer => Int -> [Int] -> writer () +putList code = + putByteList code . map fromIntegral diff --git a/src/Sound/MIDI/File/Event/SystemExclusive.hs b/src/Sound/MIDI/File/Event/SystemExclusive.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/File/Event/SystemExclusive.hs @@ -0,0 +1,44 @@ +module Sound.MIDI.File.Event.SystemExclusive + (T(..), get, put, ) where + +import Sound.MIDI.IO (ByteList) + +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser + +import qualified Sound.MIDI.Writer.Basic as Writer + +import Control.Monad (liftM, ) + + + +{-# DEPRECATED T "implement this data type properly" #-} +{- | +There are three forms of System Exclusive Messages in MIDI files: +monolithic, chopped into packets, escape form (with unrestricted binary data). + +Currently we only support first and last type explicitly. +But we leave the trailing 0xF7 markers +which can be used to detect whether the messages are actually meant as packets. + +Since I don't know where manufacturer information is in the packets form, +I omit manufacturer handling for now. +-} +data T = + Regular ByteList -- F0 + | Escape ByteList -- F7 + deriving (Show, Eq, Ord) + + +get :: Parser.C parser => Int -> parser T +get tag = + case tag of + 0xF0 -> liftM Regular $ getBigN =<< getVar + 0xF7 -> liftM Escape $ getBigN =<< getVar + _ -> Parser.giveUp "SystemExclusive: unkown message type" + +put :: Writer.C writer => T -> writer () +put sysex = + case sysex of + Regular bytes -> Writer.putByte 0xF0 >> Writer.putLenByteList bytes + Escape bytes -> Writer.putByte 0xF7 >> Writer.putLenByteList bytes diff --git a/src/Sound/MIDI/File/Load.hs b/src/Sound/MIDI/File/Load.hs --- a/src/Sound/MIDI/File/Load.hs +++ b/src/Sound/MIDI/File/Load.hs @@ -13,49 +13,88 @@ to re-use functionality from the @iff@ package. -} module Sound.MIDI.File.Load - (fromFile, fromStream, maybeFromStream, - maybeEventFromStream, - showFile, ) where + (fromFile, fromByteList, maybeFromByteList, maybeFromByteString, + showFile, ) + where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile -import qualified Sound.MIDI.Event as MIDIEvent +import qualified Sound.MIDI.File.Event.Meta as MetaEvent +import qualified Sound.MIDI.File.Event as Event + import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg -import Sound.MIDI.IO (ByteString, readBinaryFile, stringCharFromByte) -import qualified Sound.MIDI.Bit as Bit -import Data.Bits (testBit, clearBit) -import Data.Word (Word8) -import Data.Maybe (mapMaybe, fromMaybe) +import Sound.MIDI.IO (ByteList, readBinaryFile, ) +-- import qualified Sound.MIDI.Bit as Bit import Sound.MIDI.String (unlinesS) -import qualified Sound.MIDI.Parser as Parser -import qualified Sound.MIDI.ParserState as ParserState +import Sound.MIDI.Parser.Primitive +import Sound.MIDI.Parser.Class (PossiblyIncomplete, ) +import qualified Sound.MIDI.Parser.Class as Parser +import qualified Sound.MIDI.Parser.Restricted as ParserRestricted +import qualified Sound.MIDI.Parser.ByteString as ParserByteString +import qualified Sound.MIDI.Parser.Stream as ParserStream +import qualified Sound.MIDI.Parser.File as ParserFile +import qualified Sound.MIDI.Parser.State as ParserState +import qualified Sound.MIDI.Parser.Status as StatusParser +import qualified Sound.MIDI.Parser.Report as Report import qualified Control.Monad.State as State -import Control.Monad (replicateM, liftM, liftM2) -import Control.Monad.State (StateT(StateT, runStateT), evalStateT, lift) +import Control.Monad (liftM, liftM2, when, ) +import qualified Data.ByteString.Lazy as B + +-- import System.IO (hPutStrLn, stderr, ) +import Sound.MIDI.Utility (mapSnd, ) +import Data.List (genericReplicate, genericLength, ) +import Data.Maybe (catMaybes, ) + + {- | The main load function. +Warnings are written to standard error output +and an error is signaled by a user exception. +This function will not be appropriate in GUI applications. +For these, use 'fromByteList' instead. -} fromFile :: FilePath -> IO MIDIFile.T -fromFile = liftM fromStream . readBinaryFile +fromFile = + ParserFile.runIncompleteFile parse -fromStream :: ByteString -> MIDIFile.T -fromStream contents = - case maybeFromStream contents of - Right (mf,[]) -> mf - Right _ -> error "Garbage left over." -- return mf - Left msg -> error ("MIDI.Load.fromStream: " ++ msg) - -- error "Error reading midi file: unfamiliar format or file corrupt." -maybeFromStream :: ByteString -> Either String (MIDIFile.T, ByteString) -maybeFromStream = evalParser parse +{- +fromFile :: FilePath -> IO MIDIFile.T +fromFile filename = + do report <- fmap maybeFromByteList $ readBinaryFile filename + mapM_ (hPutStrLn stderr . ("MIDI.File.Load warning: " ++)) (ParserStream.warnings report) + either + (ioError . userError . ("MIDI.File.Load error: " ++)) + return + (ParserStream.result report) +-} -evalParser :: ByteParser a -> ByteString -> Either String (a, ByteString) -evalParser = runStateT +{- | +This function ignores warnings, turns exceptions into errors, +and return partial results without warnings. +Use this only in testing but never in production code! +-} +fromByteList :: ByteList -> MIDIFile.T +fromByteList contents = + either + error id + (Report.result (maybeFromByteList contents)) +maybeFromByteList :: + ByteList -> Report.T MIDIFile.T +maybeFromByteList = + ParserStream.runIncomplete parse . ParserStream.ByteList +maybeFromByteString :: + B.ByteString -> Report.T MIDIFile.T +maybeFromByteString = + ParserByteString.runIncomplete parse + + + {- | A MIDI file is made of /chunks/, each of which is either a /header chunk/ or a /track chunk/. To be correct, it must consist of one header chunk @@ -63,26 +102,32 @@ any non-header chunks that come before a header chunk. The header tells us the number of tracks to come, which is passed to 'getTracks'. -} -parse :: ByteParser MIDIFile.T +parse :: Parser.C parser => parser (PossiblyIncomplete MIDIFile.T) parse = - getChunk >>= \ chunk -> - case chunk of - Header (format, nTracks, division) -> - liftM - (MIDIFile.Cons format division . - map removeEndOfTrack . - mapMaybe trackFromChunk) - (replicateM (NonNeg.toNumber nTracks) getChunk) - _ -> parse - -{- | -Check if a chunk contains a track. -Like 'parse', if a chunk is not a track chunk, it is just ignored. + getChunk >>= \ (typ, hdLen) -> + case typ of + "MThd" -> + do (format, nTracks, division) <- + ParserRestricted.run hdLen getHeader + ~(me, tracks) <- + Parser.zeroOrMoreInc + (do (me0,track) <- getTrackChunk +{- + let trackNoEOT = track -} -trackFromChunk :: Chunk -> Maybe Track -trackFromChunk (Track t) = Just t -trackFromChunk _ = Nothing + trackNoEOT <- + maybe (return Nothing) (liftM Just . removeEndOfTrack) track + return (me0, trackNoEOT)) + let n = genericLength tracks + Parser.force $ when (n /= nTracks) $ + Parser.warn ("header says " ++ show nTracks ++ + " tracks, but " ++ show n ++ " tracks were found") + return (me, MIDIFile.Cons format division $ catMaybes tracks) + _ -> Parser.warn ("found Alien chunk <" ++ typ ++ ">") >> + Parser.skip hdLen >> + parse + {- | There are two ways to mark the end of the track: The end of the event list and the meta event 'EndOfTrack'. @@ -90,25 +135,27 @@ at the end of the track and complain about all 'EndOfTrack's within the event list. -} -removeEndOfTrack :: Track -> Track +removeEndOfTrack :: Parser.C parser => Track -> parser Track removeEndOfTrack xs = - fromMaybe - (error "Empty track, missing EndOfTrack") - (do (initEvents, lastEvent) <- EventList.viewR xs + maybe + (Parser.warn "Empty track, missing EndOfTrack" >> + return xs) + (\(initEvents, lastEvent) -> let (eots, track) = EventList.partition isEndOfTrack initEvents - if EventList.null eots - then return () - else error "EndOfTrack inside a track" - if isEndOfTrack (snd lastEvent) - then return () - else error "Track does not end with EndOfTrack" - return track) + in do Parser.force $ when + (not $ EventList.null eots) + (Parser.warn "EndOfTrack inside a track") + Parser.force $ when + (not $ isEndOfTrack $ snd lastEvent) + (Parser.warn "Track does not end with EndOfTrack") + return track) + (EventList.viewR xs) -isEndOfTrack :: Event -> Bool +isEndOfTrack :: Event.T -> Bool isEndOfTrack ev = case ev of - MetaEvent EndOfTrack -> True + Event.MetaEvent MetaEvent.EndOfTrack -> True _ -> False {- @@ -133,38 +180,35 @@ four bytes for the size of the coming data, and the data itself. -} -getChunk :: ByteParser Chunk +getChunk :: Parser.C parser => parser (String, NonNeg.Integer) getChunk = - do - (ty, body) <- getPlainChunk - case ty of - "MThd" -> - return $ Header $ - case evalParser getHeader body of - Right (hd,[]) -> hd - Right (_,_) -> error "header chunk too large" - Left msg -> error ("getChunk header: " ++ msg) - "MTrk" -> - return $ Track $ - either (\msg -> error ("getChunk track: " ++ msg)) id $ - evalStateT (evalStateT getTrack initReadEvent) body - _ -> return (AlienChunk ty body) + liftM2 (,) + (getString 4) -- chunk type: header or track + (getNByteCardinal 4) + -- chunk body -data Chunk = - Header (MIDIFile.Type, NonNeg.Int, Division) - | Track Track - | AlienChunk String ByteString - deriving Eq +getTrackChunk :: Parser.C parser => parser (PossiblyIncomplete (Maybe Track)) +getTrackChunk = + do (typ, len) <- getChunk + if typ=="MTrk" + then liftM (mapSnd Just) $ + ParserRestricted.run len $ + StatusParser.run getTrack + else Parser.warn ("found Alien chunk <" ++ typ ++ "> in track section") >> + Parser.skip len >> + return (Nothing, Nothing) + + {- | Parse a Header Chunk. A header consists of a format (0, 1, or 2), the number of track chunks to come, and the smallest time division to be used in reading the rest of the file. -} -getHeader :: ByteParser (MIDIFile.Type, NonNeg.Int, Division) +getHeader :: Parser.C parser => parser (MIDIFile.Type, NonNeg.Int, Division) getHeader = do - format <- liftM toEnum get2 + format <- makeEnum =<< get2 nTracks <- liftM (NonNeg.fromNumberMsg "MIDI.Load.getHeader") get2 division <- getDivision return (format, nTracks, division) @@ -173,248 +217,31 @@ The division is implemented thus: the most significant bit is 0 if it's in ticks per quarter note; 1 if it's an SMPTE value. -} -getDivision :: ByteParser Division +getDivision :: Parser.C parser => parser Division getDivision = do x <- get1 y <- get1 - return (if x < 128 - then Ticks (NonNeg.fromNumberMsg "MIDI.Load.getDivision" (x*256+y)) - else SMPTE (256-x) y) + return $ + if x < 128 + then Ticks (NonNeg.fromNumberMsg "MIDI.Load.getDivision" (x*256+y)) + else SMPTE (256-x) y {- | A track is a series of events. Parse a track, stopping when the size is zero. -} -getTrack :: TrackParser MIDIFile.Track +getTrack :: Parser.C parser => StatusParser.T parser (PossiblyIncomplete MIDIFile.Track) getTrack = liftM - EventList.fromPairList - (ParserState.zeroOrMore getSchedEvent) - -{- | -Each event is preceded by the delta time: the time in ticks between the -last event and the current event. Parse a time and an event, ignoring -System Exclusive messages. --} -getSchedEvent :: TrackParser MIDIFile.SchedEvent -getSchedEvent = liftM2 (,) (lift getVar) getEvent + (mapSnd EventList.fromPairList) + (ParserState.zeroOrMore Event.getTrackEvent) -maybeEventFromStream :: ByteString -> Either String (MIDIFile.Event, ByteString) -maybeEventFromStream = evalParser getIndividualEvent - - -{- | -Parse an event, but without a state for the current type of events -like in 'getEvent'. --} -getIndividualEvent :: ByteParser MIDIFile.Event -getIndividualEvent = - do - tag <- get1 - case tag of - 240 -> liftM SysExStart $ getBigN =<< getVar - 247 -> liftM SysExCont $ getBigN =<< getVar -{- - 255 -> - do - code <- get1 - size <- getVar - liftM MetaEvent (getMetaEvent code size) --} - _ -> if tag>127 - then let parseEv = decodeStatus tag - in get1 >>= parseEvent parseEv - else fail "There is no default MIDI event type when parsing individual MIDI events." - - -{- | -Parse an event. Note that in the case of a regular MIDI Event, the tag is -the status, and we read the first byte of data before we call 'getMIDIEvent'. -In the case of a MIDIEvent with running status, we find out the status from -the parser (it's been nice enough to keep track of it for us), and the tag -that we've already gotten is the first byte of data. --} -getEvent :: TrackParser MIDIFile.Event -getEvent = - do - tag <- lift get1 - case tag of - 240 -> liftM SysExStart $ lift (getBigN =<< getVar) - 247 -> liftM SysExCont $ lift (getBigN =<< getVar) - 255 -> lift $ - do - code <- get1 - size <- getVar - liftM MetaEvent (getMetaEvent code size) - _ -> if tag>127 - then let parseEv = decodeStatus tag - in putEventParser parseEv >> lift (get1 >>= parseEvent parseEv) - else -- running status - lift . flip parseEvent tag =<< getEventParser - -{- | -Simpler version of 'getTrack', used in the Show functions. --} -getPlainTrack :: TrackParser MIDIFile.Track -getPlainTrack = - liftM - EventList.fromPairList - (ParserState.oneOrMore getSchedEvent) - - -newtype EventParser = - EventParser {parseEvent :: Int -> ByteParser MIDIFile.Event} - -{- | -Find out the status (MIDIEvent type and channel) given a byte of data. --} -decodeStatus :: Int -> EventParser -decodeStatus tag = - let (code, channel) = Bit.splitAt 4 tag - in EventParser (getMIDIEvent code (MIDIEvent.toChannel channel)) - -{- | -Parse a MIDI Event. -Note that since getting the first byte is a little complex -(there are issues with running status), -it has already been handled for us by 'getEvent'. --} -getMIDIEvent :: Int -> MIDIEvent.Channel -> Int -> ByteParser MIDIFile.Event -getMIDIEvent code channel firstData = - let pitch = MIDIEvent.toPitch firstData - getVel = liftM MIDIEvent.toVelocity get1 - getME = - case code of - 08 -> liftM (MIDIEvent.NoteOff pitch) getVel - 09 -> liftM (MIDIEvent.NoteOn pitch) getVel - 10 -> liftM (MIDIEvent.PolyAfter pitch) get1 - 11 -> liftM (MIDIEvent.Control (toEnum firstData)) get1 - 12 -> return (MIDIEvent.ProgramChange (MIDIEvent.toProgram firstData)) - 13 -> return (MIDIEvent.MonoAfter firstData) - 14 -> liftM (\msb -> MIDIEvent.PitchBend (firstData+128*msb)) get1 - _ -> fail ("invalid MIDIEvent code:" ++ show code) - in liftM (MIDIEvent channel) getME - -{- | -Parse a MetaEvent. --} -getMetaEvent :: Int -> NonNeg.Integer -> ByteParser MetaEvent -getMetaEvent code size = - case code of - 000 -> liftM SequenceNum get2 - 001 -> getText size TextEvent - 002 -> getText size Copyright - 003 -> getText size TrackName - 004 -> getText size InstrName - 005 -> getText size Lyric - 006 -> getText size Marker - 007 -> getText size CuePoint - - 032 -> liftM (MIDIPrefix . MIDIEvent.toChannel) get1 - 047 -> return EndOfTrack - 081 -> liftM (SetTempo . NonNeg.fromNumberMsg "MIDI.Load.getMetaEvent") get3 - - 084 -> do {hrs <- get1 ; mins <- get1 ; secs <- get1; - frames <- get1 ; bits <- get1 ; - return (SMPTEOffset hrs mins secs frames bits)} - - 088 -> do - n <- get1 - d <- get1 - c <- get1 - b <- get1 - return (TimeSig n d c b) - - 089 -> do - sf <- get1 - mi <- get1 - return (KeySig (toKeyName sf) (toEnum mi)) - - 127 -> liftM SequencerSpecific (getBigN size) - - _ -> liftM (Unknown code) (getBigN size) - -getText :: NonNeg.Integer -> (String -> MetaEvent) -> ByteParser MetaEvent -getText size c = liftM c (getString size) - -toKeyName :: Int -> Key -toKeyName sf = toEnum (mod (sf+7) 15) - -{- | -'getByte' gets a single byte from the input. --} -getByte :: ByteParser Word8 -getByte = StateT $ maybe (Left "reached end of file") Right . viewL - -viewL :: [a] -> Maybe (a, [a]) -viewL xs = - case xs of - [] -> Nothing - (c:cs) -> Just (c,cs) - -{- | -@getN n@ returns n characters (bytes) from the input. --} -getN :: NonNeg.Int -> ByteParser ByteString -getN n = replicateM (NonNeg.toNumber n) getByte - -getString :: NonNeg.Integer -> ByteParser String -getString n = liftM stringCharFromByte (getBigN n) - -getBigN :: NonNeg.Integer -> ByteParser ByteString -getBigN n = - sequence $ - Bit.replicateBig - (succ (fromIntegral (maxBound :: NonNeg.Int))) - (NonNeg.toNumber n) - getByte - - -{- | -'get1', 'get2', 'get3', and 'get4' take 1-, 2-, 3-, or -4-byte numbers from the input (respectively), convert the base-256 data -into a single number, and return. --} -get1 :: ByteParser Int -get1 = liftM fromIntegral getByte - -getNByteInt :: NonNeg.Int -> ByteParser Int -getNByteInt n = - liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1) - -get2, get3, get4 :: ByteParser Int -get2 = getNByteInt 2 -get3 = getNByteInt 3 -get4 = getNByteInt 4 - -{- | -/Variable-length quantities/ are used often in MIDI notation. -They are represented in the following way: -Each byte (containing 8 bits) uses the 7 least significant bits to store information. -The most significant bit is used to signal whether or not more information is coming. -If it's @1@, another byte is coming. -If it's @0@, that byte is the last one. -'getVar' gets a variable-length quantity from the input. --} -getVar :: ByteParser NonNeg.Integer -getVar = - liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes - -{- | -The returned list contains only bytes with the most significant bit cleared. -These are digits of a 128-ary number. --} -getVarBytes :: ByteParser [Word8] -getVarBytes = - do - digit <- getByte - if flip testBit 7 digit -- if it's the last byte - then liftM (flip clearBit 7 digit :) getVarBytes - else return [digit] +-- * show contents of a MIDI file for debugging +{-# DEPRECATED showFile "only use this for debugging" #-} {- | Functions to show the decoded contents of a MIDI file in an easy-to-read format. This is for debugging purposes and should not be used in production code. @@ -422,40 +249,43 @@ showFile :: FilePath -> IO () showFile fileName = putStr . showChunks =<< readBinaryFile fileName -showChunks :: ByteString -> String -showChunks mf = showMR getChunks (unlinesS . map pp) mf "" +showChunks :: ByteList -> String +showChunks mf = + showMR getChunks (\(me,cs) -> + unlinesS (map pp cs) . + maybe id (\e -> showString ("incomplete chunk list: " ++ e ++ "\n")) me) mf "" where - pp :: (String, ByteString) -> ShowS + pp :: (String, ByteList) -> ShowS pp ("MThd",contents) = showString "Header: " . showMR getHeader shows contents pp ("MTrk",contents) = showString "Track:\n" . - showMR (evalStateT getPlainTrack initReadEvent) - (\track str -> + showMR (StatusParser.run getTrack) + (\(me,track) str -> EventList.foldr MIDIFile.showTime (\e -> MIDIFile.showEvent e . showString "\n") - str track) + (maybe "" (\e -> "incomplete track: " ++ e ++ "\n") me ++ str) track) contents pp (ty,contents) = - showString "Chunk: " . + showString "Alien Chunk: " . showString ty . showString " " . shows contents . showString "\n" -showMR :: ByteParser a -> (a->ShowS) -> ByteString -> ShowS + +showMR :: ParserStream.T ParserStream.ByteList a -> (a->ShowS) -> ByteList -> ShowS showMR m pp contents = - case evalParser m contents of - Left msg -> - showString "Parse failed: " . showString (msg++"\n") . shows contents - Right (a,[] ) -> pp a - Right (a,junk) -> pp a . showString "Junk: " . shows junk + let report = ParserStream.run m (ParserStream.ByteList contents) + in unlinesS (map showString $ Report.warnings report) . + either showString pp (Report.result report) + {- | -These two functions, the 'getPlainChunk' and 'getChunks' parsers, +The two functions, the 'getChunk' and 'getChunks' parsers, do not combine directly into a single master parser. Rather, they should be used to chop parts of a midi file up into chunks of bytes which can be outputted separately. @@ -466,38 +296,10 @@ * leftover slop (should be empty in correctly formatted file) -} -getChunks :: ByteParser [(String, ByteString)] -getChunks = Parser.zeroOrMore getPlainChunk - -getPlainChunk :: ByteParser (String, ByteString) -getPlainChunk = - liftM2 (,) - (getString 4) -- chunk type: header or track - (getN . NonNeg.fromNumberMsg "getPlainChunk" =<< get4) - -- chunk body - - -type ByteParser a = Parser.T ByteString a - -{- | -The 'TrackParser' monad parses a track of a MIDI File. -In MIDI, a shortcut is used for long strings of similar MIDI events: -If a stream of consecutive events all have the same type and channel, -the type and channel can be omitted for all but the first event. -To implement this /feature/, -the parser must keep track of the type and channel of the most recent MIDI Event. -This is done by setting an 'EventParser' parser, -which parses the data bytes according to the currently active event type. --} -type TrackParser a = ParserState.T EventParser ByteString a - - -putEventParser :: EventParser -> TrackParser () -putEventParser = State.put - -getEventParser :: TrackParser EventParser -getEventParser = State.get - -initReadEvent :: EventParser -initReadEvent = - EventParser (const (return (error "At beginning, no event type set so far"))) +getChunks :: + Parser.C parser => parser (PossiblyIncomplete [(String, ByteList)]) +getChunks = + Parser.zeroOrMore $ + do (typ, len) <- getChunk + body <- sequence (genericReplicate len getByte) + return (typ, body) diff --git a/src/Sound/MIDI/File/Save.hs b/src/Sound/MIDI/File/Save.hs --- a/src/Sound/MIDI/File/Save.hs +++ b/src/Sound/MIDI/File/Save.hs @@ -7,225 +7,115 @@ -} module Sound.MIDI.File.Save - (toFile, toStream, toOpenStream, eventToStream, ) where + (toSeekableFile, toFile, toByteList, toByteString, + toCompressedByteString, ) where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile -import qualified Sound.MIDI.Event as MIDIEvent +import qualified Sound.MIDI.File.Event as Event +import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg -import qualified Sound.MIDI.Bit as Bit -import Data.Bits ((.|.)) -import Sound.MIDI.IO (ByteString, writeBinaryFile, stringByteFromChar) -import Control.Monad.Writer (Writer, tell, execWriter) -import Data.Ix (Ix, index) -import Data.List (genericLength) +import qualified Sound.MIDI.Writer.Status as StatusWriter +import qualified Sound.MIDI.Writer.Basic as Writer +import Control.Monad.Reader (ask, ) +import Control.Monad.Trans (lift, ) +import Sound.MIDI.IO (ByteList, writeBinaryFile, ) + +import qualified Data.ByteString.Lazy as B + + + {- | +Directly write to a file. +Since chunks lengths are not known before writing, +we need to seek in a file. +Thus you cannot write to pipes with this function. +-} +toSeekableFile :: FilePath {- ^ file name -} -> MIDIFile.T -> IO () +toSeekableFile fn = + Writer.runSeekableFile fn . StatusWriter.toWriterWithoutStatus . put + +{- | The function 'toFile' is the main function for writing 'MIDIFile.T' values to an actual file. -} toFile :: FilePath {- ^ file name -} -> MIDIFile.T -> IO () -toFile fn mf = writeBinaryFile fn (toStream mf) +toFile fn mf = writeBinaryFile fn (toByteList mf) {- MIDI files are first converted to a monadic string computation -using the function 'outMF', +using the function 'put', and then \"executed\" using 'execWriter'. -} {- | -Convert a MIDI file to a ByteString. +Convert a MIDI file to a 'ByteList'. -} -toStream :: MIDIFile.T -> ByteString -toStream = execWriter . outMF outChunk +toByteList :: MIDIFile.T -> ByteList +toByteList = + Writer.runByteList . StatusWriter.toWriterWithoutStatus . put {- | -Convert a MIDI file to a ByteString -while replacing chunk lengths by (-1). -This way writing the file is more lazy. -I don't know whether this is useful for anything, -thus simply don't use it. +Convert a MIDI file to a lazy 'B.ByteString'. -} -{-# DEPRECATED toOpenStream "use toStream instead" #-} -toOpenStream :: MIDIFile.T -> ByteString -toOpenStream = execWriter . outMF outOpenChunk - - -outMF :: OutChunk -> MIDIFile.T -> MIDIWriter () -outMF outChk (MIDIFile.Cons mft divisn trks) = - do - outChunk "MThd" (do - outInt 2 (fromEnum mft) -- format (type 0, 1 or 2) - outInt 2 (length trks) -- number of tracks to come - outputDivision divisn) -- time unit - mapM_ (outputTrack outChk) trks - -outputDivision :: Division -> MIDIWriter () -outputDivision (Ticks nticks) = - outInt 2 (NonNeg.toNumber nticks) -outputDivision (SMPTE mode nticks) = - do - outInt 1 (256-mode) - outInt 1 nticks - -outputTrack :: OutChunk -> Track -> MIDIWriter () -outputTrack outChk trk = - outChk "MTrk" $ - EventList.mapM_ outVar outputEvent $ - EventList.snoc trk 0 (MetaEvent EndOfTrack) - - -eventToStream :: MIDIFile.Event -> ByteString -eventToStream = execWriter . outputEvent +toByteString :: MIDIFile.T -> B.ByteString +toByteString = + Writer.runByteString . StatusWriter.toWriterWithoutStatus . put {- | -The following functions encode various 'MIDIFile.T' elements -into the raw data of a standard MIDI file. +Convert a MIDI file to a lazy 'B.ByteString'. +It converts @NoteOff p 64@ to @NoteOn p 0@ +and then uses the running MIDI status in order to compress the file. -} +toCompressedByteString :: MIDIFile.T -> B.ByteString +toCompressedByteString = + Writer.runByteString . StatusWriter.toWriterWithStatus . put . + MIDIFile.implicitNoteOff -outputEvent :: MIDIFile.Event -> MIDIWriter () -outputEvent e = - case e of - MIDIEvent ch mevent -> outputMIDIEvent ch mevent - MetaEvent mevent -> outputMetaEvent mevent - SysExStart bytes -> outInt 1 240 >> outLenByteStr bytes - SysExCont bytes -> outInt 1 247 >> outLenByteStr bytes -outputMIDIEvent :: MIDIEvent.Channel -> MIDIEvent.T -> MIDIWriter () -outputMIDIEvent c e = - let outC = outChan c - in case e of - (MIDIEvent.NoteOff p v) -> outC 8 [MIDIEvent.fromPitch p, MIDIEvent.fromVelocity v] - (MIDIEvent.NoteOn p v) -> outC 9 [MIDIEvent.fromPitch p, MIDIEvent.fromVelocity v] - (MIDIEvent.PolyAfter p pr) -> outC 10 [MIDIEvent.fromPitch p, pr] - (MIDIEvent.Control cn cv) -> outC 11 [fromEnum cn, cv] - (MIDIEvent.ProgramChange pn) -> outC 12 [MIDIEvent.fromProgram pn] - (MIDIEvent.MonoAfter pr) -> outC 13 [pr] - (MIDIEvent.PitchBend pb) -> - let (hi,lo) = Bit.splitAt 7 pb in outC 14 [lo,hi] -- little-endian!! --- output a channel event -outChan :: MIDIEvent.Channel -> Int -> [Int] -> MIDIWriter () -outChan chan code bytes = - do outInt 1 (16*code + MIDIEvent.fromChannel chan) - mapM_ (outInt 1) bytes +put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer () +put (MIDIFile.Cons mft divisn trks) = + do + putChunk "MThd" $ lift $ + do + Writer.putInt 2 (fromEnum mft) -- format (type 0, 1 or 2) + Writer.putInt 2 (length trks) -- number of tracks to come + putDivision divisn -- time unit + mapM_ putTrack trks -outMetaByteStr :: Int -> ByteString -> MIDIWriter () -outMetaByteStr code bytes = +putDivision :: Writer.C writer => Division -> writer () +putDivision (Ticks nticks) = + Writer.putInt 2 (NonNeg.toNumber nticks) +putDivision (SMPTE mode nticks) = do - outInt 1 255 - outInt 1 code - outLenByteStr bytes + Writer.putIntAsByte (256-mode) + Writer.putIntAsByte nticks -outMetaStr :: Int -> String -> MIDIWriter () -outMetaStr code = - outMetaByteStr code . stringByteFromChar +putTrack :: Writer.C writer => Track -> StatusWriter.T writer () +putTrack trk = + putChunk "MTrk" $ + EventList.mapM_ (lift . Writer.putVar) Event.put $ + EventList.snoc trk 0 (Event.MetaEvent MetaEvent.EndOfTrack) -outMetaList :: Int -> [Int] -> MIDIWriter () -outMetaList code = - outMetaByteStr code . map fromIntegral --- As with outChunk, there are other ways to do this - but --- it's not obvious which is best or if performance is a big issue. -outMetaMW :: Int -> MIDIWriter () -> MIDIWriter () -outMetaMW code = outMetaByteStr code . execWriter -outputMetaEvent :: MetaEvent -> MIDIWriter () -outputMetaEvent (SequenceNum num) = outMetaMW 0 (outInt 2 num) -outputMetaEvent (TextEvent s) = outMetaStr 1 s -outputMetaEvent (Copyright s) = outMetaStr 2 s -outputMetaEvent (TrackName s) = outMetaStr 3 s -outputMetaEvent (InstrName s) = outMetaStr 4 s -outputMetaEvent (Lyric s) = outMetaStr 5 s -outputMetaEvent (Marker s) = outMetaStr 6 s -outputMetaEvent (CuePoint s) = outMetaStr 7 s -outputMetaEvent (MIDIPrefix c) = outMetaList 32 [MIDIEvent.fromChannel c] -outputMetaEvent EndOfTrack = outMetaList 47 [] - -outputMetaEvent (SetTempo tp) = outMetaMW 81 (outInt 3 (NonNeg.toNumber tp)) -outputMetaEvent (SMPTEOffset hr mn se fr ff) - = outMetaList 84 [hr,mn,se,fr,ff] -outputMetaEvent (TimeSig n d c b) = outMetaList 88 [n,d,c,b] -outputMetaEvent (KeySig sf mi) = outMetaList 89 [sf', fromEnum mi] - where k = index (KeyCf,KeyCs) sf - 7 - sf' = if (k >= 0) - then k - else 255+k -outputMetaEvent (SequencerSpecific codes) - = outMetaByteStr 127 codes -outputMetaEvent (Unknown typ s) = outMetaByteStr typ s - -{- | -The 'MIDIWriter' accumulates a String. -For all the usual reasons, the String is represented by ShowS. --} - -type MIDIWriter a = Writer ByteString a - -outInt :: Int -> Int -> MIDIWriter () -outInt a = outByteStr . map fromIntegral . Bit.someBytes a - -outStr :: String -> MIDIWriter () -outStr = outByteStr . stringByteFromChar - -outByteStr :: ByteString -> MIDIWriter () -outByteStr = tell - -outLenByteStr :: ByteString -> MIDIWriter () -outLenByteStr bytes = - do outVar (genericLength bytes) - outByteStr bytes - -{- | -Numbers of variable size are represented by sequences of 7-bit blocks -tagged (in the top bit) with a bit indicating: -(1) that more data follows; or -(0) that this is the last block. --} - -outVar :: NonNeg.Integer -> MIDIWriter () -outVar n = - let bytes = map fromIntegral $ Bit.toBase 128 n - in case bytes of - [] -> outInt 1 0 - (_:bs) -> - let highBits = map (const 128) bs ++ [0] - in outByteStr (zipWith (.|.) highBits bytes) - - -outTag :: String -> MIDIWriter () -outTag tag@(_:_:_:_:[]) = outStr tag -outTag tag = - error ("SaveMIDI.outChunk: Chunk name " ++ tag ++ - " does not consist of 4 characters.") - -{- -Note: here I've chosen to compute the track twice -rather than store it. Other options are worth exploring. --} - -type OutChunk = String -> MIDIWriter () -> MIDIWriter () - -outChunk, outOpenChunk :: OutChunk - -outChunk tag m = +putChunk :: Writer.C writer => + String -> StatusWriter.T writer () -> StatusWriter.T writer () +putChunk tag m = do - outTag tag - let str = execWriter m - outInt 4 (length str) - outByteStr str + lift $ putTag tag + compress <- StatusWriter.Cons ask + lift $ Writer.putLengthBlock 4 $ + StatusWriter.toWriter compress m -{- | -The MIDI standard seems to require a fixed length for all chunks. -Chunks with unknown length are essential for infinite music -and music that is created on the fly. --} -outOpenChunk tag m = - do - outTag tag - outInt 4 (-1) - m +putTag :: Writer.C writer => String -> writer () +putTag tag@(_:_:_:_:[]) = Writer.putStr tag +putTag tag = + error ("SaveMIDI.putChunk: Chunk name " ++ tag ++ + " does not consist of 4 characters.") diff --git a/src/Sound/MIDI/General.hs b/src/Sound/MIDI/General.hs --- a/src/Sound/MIDI/General.hs +++ b/src/Sound/MIDI/General.hs @@ -6,27 +6,29 @@ module Sound.MIDI.General where -import qualified Sound.MIDI.Event as MidiEvent +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import Sound.MIDI.Message.Channel (Channel, toChannel, ) import Data.Ix(Ix) import qualified Data.List as List -import Sound.MIDI.Utility (mapFst, mapSnd, ) -import Test.QuickCheck (Gen, Arbitrary(..), choose, ) -import System.Random (Random(random,randomR), RandomGen) +import Sound.MIDI.Utility (mapSnd, + enumRandomR, boundedEnumRandom, chooseEnum, ) +import Test.QuickCheck (Arbitrary(..), ) +import System.Random (Random(random,randomR), ) {- * Instrument definitions -} -instrumentNameToProgram :: String -> Maybe MidiEvent.Program +instrumentNameToProgram :: String -> Maybe VoiceMsg.Program instrumentNameToProgram = - fmap MidiEvent.toProgram . flip List.elemIndex instrumentNames + fmap VoiceMsg.toProgram . flip List.elemIndex instrumentNames instrumentNames :: [String] instrumentNames = map fst instrumentPrograms -instrumentPrograms :: [(String, MidiEvent.Program)] +instrumentPrograms :: [(String, VoiceMsg.Program)] instrumentPrograms = - map (mapSnd MidiEvent.toProgram) [ + map (mapSnd VoiceMsg.toProgram) [ ("Acoustic Grand Piano",0), ("Bright Acoustic Piano",1), ("Electric Grand Piano",2), ("Honky Tonk Piano",3), ("Rhodes Piano",4), ("Chorused Piano",5), @@ -93,14 +95,14 @@ ("Applause",126), ("Gunshot",127) ] -instrumentFromProgram :: MidiEvent.Program -> Instrument -instrumentFromProgram = toEnum . MidiEvent.fromProgram +instrumentFromProgram :: VoiceMsg.Program -> Instrument +instrumentFromProgram = toEnum . VoiceMsg.fromProgram -instrumentToProgram :: Instrument -> MidiEvent.Program -instrumentToProgram = MidiEvent.toProgram . fromEnum +instrumentToProgram :: Instrument -> VoiceMsg.Program +instrumentToProgram = VoiceMsg.toProgram . fromEnum -instrumentChannels :: [MidiEvent.Channel] -instrumentChannels = map MidiEvent.toChannel $ [0..8] ++ [10..15] +instrumentChannels :: [Channel] +instrumentChannels = map toChannel $ [0..8] ++ [10..15] instruments :: [Instrument] instruments = enumFromTo minBound maxBound @@ -185,23 +187,23 @@ {- * Drum definitions -} -drumChannel :: MidiEvent.Channel -drumChannel = MidiEvent.toChannel 9 +drumChannel :: Channel +drumChannel = toChannel 9 -drumProgram :: MidiEvent.Program -drumProgram = MidiEvent.toProgram 0 +drumProgram :: VoiceMsg.Program +drumProgram = VoiceMsg.toProgram 0 -drumMinKey :: MidiEvent.Pitch -drumMinKey = MidiEvent.toPitch 35 +drumMinKey :: VoiceMsg.Pitch +drumMinKey = VoiceMsg.toPitch 35 -drumKeyTable :: [(Drum, MidiEvent.Pitch)] +drumKeyTable :: [(Drum, VoiceMsg.Pitch)] drumKeyTable = zip drums [drumMinKey ..] -drumFromKey :: MidiEvent.Pitch -> Drum -drumFromKey = toEnum . MidiEvent.subtractPitch drumMinKey +drumFromKey :: VoiceMsg.Pitch -> Drum +drumFromKey = toEnum . VoiceMsg.subtractPitch drumMinKey -drumToKey :: Drum -> MidiEvent.Pitch -drumToKey = flip MidiEvent.increasePitch drumMinKey . fromEnum +drumToKey :: Drum -> VoiceMsg.Pitch +drumToKey = flip VoiceMsg.increasePitch drumMinKey . fromEnum drums :: [Drum] drums = enumFromTo minBound maxBound @@ -234,18 +236,3 @@ instance Arbitrary Drum where arbitrary = chooseEnum coarbitrary = error "GeneralMIDI.Drum.coarbitrary not implemented" - - - - --- auxiliary functions - -enumRandomR :: (Enum a, RandomGen g) => (a,a) -> g -> (a,g) -enumRandomR (l,r) = - mapFst toEnum . randomR (fromEnum l, fromEnum r) - -boundedEnumRandom :: (Enum a, Bounded a, RandomGen g) => g -> (a,g) -boundedEnumRandom = enumRandomR (minBound, maxBound) - -chooseEnum :: (Enum a, Bounded a, Random a) => Gen a -chooseEnum = choose (minBound, maxBound) diff --git a/src/Sound/MIDI/IO.hs b/src/Sound/MIDI/IO.hs --- a/src/Sound/MIDI/IO.hs +++ b/src/Sound/MIDI/IO.hs @@ -3,7 +3,7 @@ -} module Sound.MIDI.IO (openBinaryFile, readBinaryFile, writeBinaryFile, - ByteString, stringCharFromByte, stringByteFromChar) + ByteList, listCharFromByte, listByteFromChar) where import System.IO @@ -12,26 +12,26 @@ import Data.Char (ord, chr) import Data.Word (Word8) -type ByteString = [Word8] +type ByteList = [Word8] {- | Hugs makes trouble here because it performs UTF-8 conversions. E.g. @[255]@ is output as @[195,191]@ -It would be easy to replace these routines by FastPackedString(fps).ByteString.Lazy, +It would be easy to replace these routines by FastPackedString(fps).ByteList.Lazy, however this introduces a new package dependency. -} -writeBinaryFile :: FilePath -> ByteString -> IO () +writeBinaryFile :: FilePath -> ByteList -> IO () writeBinaryFile path str = bracket (openBinaryFile path WriteMode) hClose - (flip hPutStr (stringCharFromByte str)) + (flip hPutStr (listCharFromByte str)) -stringCharFromByte :: ByteString -> String -stringCharFromByte = map (chr . fromIntegral) +listCharFromByte :: ByteList -> String +listCharFromByte = map (chr . fromIntegral) -readBinaryFile :: FilePath -> IO ByteString +readBinaryFile :: FilePath -> IO ByteList readBinaryFile path = - liftM stringByteFromChar . + liftM listByteFromChar . hGetContents =<< openBinaryFile path ReadMode -stringByteFromChar :: String -> ByteString -stringByteFromChar = map (fromIntegral . ord) +listByteFromChar :: String -> ByteList +listByteFromChar = map (fromIntegral . ord) diff --git a/src/Sound/MIDI/Manufacturer.hs b/src/Sound/MIDI/Manufacturer.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Manufacturer.hs @@ -0,0 +1,366 @@ +{- | +MIDI device manufacturers and their id's. +-} +module Sound.MIDI.Manufacturer + (T, get, put, + + sequential, idp, octavePlateau, moog, passport, lexicon, kurzweil, + fender, gulbransen, akg, voyce, waveframe, ada, garfield, ensoniq, + oberheim, apple, greyMatter, digidesign, palmTree, jlCooper, lowrey, + adamsSmith, emu, harmony, art, baldwin, eventide, inventronics, + keyConcepts, clarity, + + timeWarner, digitalMusic, iota, newEngland, artisyn, ivl, + southernMusic, lakeButler, alesis, dod, studerEditech, perfectFret, + kat, opcode, rane, anadi, kmx, brenell, peavey, systems360, + spectrum, marquis, zeta, axxes, orban, kti, breakaway, cae, + rocktron, pianoDisc, cannon, rogers, blueSkyLogic, encore, uptown, + voce, cti, ssResearch, broderbund, allenOrgan, musicQuest, aphex, + gallienKrueger, ibm, hotzInstruments, etaLighting, nsi, adLib, + richmond, microsoft, softwareToolworks, rjmgNiche, intone, + grooveTubes, euphonix, interMIDI, loneWolf, musonix, taHorng, eTek, + electrovoice, midisoft, qSoundLabs, westrex, nVidia, ess, mediaTrix, + brooktree, otari, keyElectronics, crystalake, crystal, rockwell, + siliconGraphics, midiman, preSonus, topaz, castLighting, + microsoftConsumer, fastForward, headspace, vanKoevering, altech, + vlsi, chromaticResearch, sapphire, idrc, justonic, torComp, newtek, + soundSculpture, walker, pavo, inVision, tSquareDesign, nemesys, dbx, + syndyne, bitheadz, cakewalk, staccato, nationalSemiconductor, + boomTheory, virtualDSP, antares, angelSoftware, stLouis, lyrrus, + + passac, siel, synthaxe, hohner, twister, solton, jellinghaus, + southworth, ppg, jen, ssl, audioVeritrieb, elka, dynacord, + viscount, clavia, audioArchitect, generalMusic, soundcraft, wersi, + avab, digigram, waldorf, quasimidi, + + dream, strandLighting, amek, drBohm, trident, realWorldDesign, + yesTechnology, audiomatica, bontempiFarfisa, fbtElectronica, miditemp, + larkingAudio, zero88lighting, miconAudio, forefront, kenton, adb, + jimMarshall, dda, bssAudio, tcElectronic, medeli, charlieLab, + blueChip, beeOH, lgSemiconductor, tesi, emagic, behringer, access, + synoptic, hanmesoft, terratec, proel, ibk, + + kawai, roland, korg, yamaha, casio, kamiya, akai, japanVictor, + mesosha, hoshinoGakki, fujitsuElect, sony, nisshinOnpa, teac, + matsushitaElec, fostex, zoom, midori, matsushitaComm, suzuki, + + nonCommercial, nonRealTime, realTime, + ) where + + +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser + +import qualified Sound.MIDI.Writer.Basic as Writer + +import Control.Monad (liftM2, ) + +import Data.Word (Word8) + + + +data T = + Short Word8 + | Extended Word8 Word8 + deriving (Show, Eq, Ord) + +-- * North American Group + +sequential, idp, octavePlateau, moog, passport, lexicon, kurzweil, + fender, gulbransen, akg, voyce, waveframe, ada, garfield, ensoniq, + oberheim, apple, greyMatter, digidesign, palmTree, jlCooper, lowrey, + adamsSmith, emu, harmony, art, baldwin, eventide, inventronics, + keyConcepts, clarity, + + timeWarner, digitalMusic, iota, newEngland, artisyn, ivl, + southernMusic, lakeButler, alesis, dod, studerEditech, perfectFret, + kat, opcode, rane, anadi, kmx, brenell, peavey, systems360, + spectrum, marquis, zeta, axxes, orban, kti, breakaway, cae, + rocktron, pianoDisc, cannon, rogers, blueSkyLogic, encore, uptown, + voce, cti, ssResearch, broderbund, allenOrgan, musicQuest, aphex, + gallienKrueger, ibm, hotzInstruments, etaLighting, nsi, adLib, + richmond, microsoft, softwareToolworks, rjmgNiche, intone, + grooveTubes, euphonix, interMIDI, loneWolf, musonix, taHorng, eTek, + electrovoice, midisoft, qSoundLabs, westrex, nVidia, ess, mediaTrix, + brooktree, otari, keyElectronics, crystalake, crystal, rockwell, + siliconGraphics, midiman, preSonus, topaz, castLighting, + microsoftConsumer, fastForward, headspace, vanKoevering, altech, + vlsi, chromaticResearch, sapphire, idrc, justonic, torComp, newtek, + soundSculpture, walker, pavo, inVision, tSquareDesign, nemesys, dbx, + syndyne, bitheadz, cakewalk, staccato, nationalSemiconductor, + boomTheory, virtualDSP, antares, angelSoftware, stLouis, lyrrus :: T + +sequential = Short 0x01 +idp = Short 0x02 +octavePlateau = Short 0x03 +moog = Short 0x04 +passport = Short 0x05 +lexicon = Short 0x06 +kurzweil = Short 0x07 +fender = Short 0x08 +gulbransen = Short 0x09 +akg = Short 0x0A +voyce = Short 0x0B +waveframe = Short 0x0C +ada = Short 0x0D +garfield = Short 0x0E +ensoniq = Short 0x0F +oberheim = Short 0x10 +apple = Short 0x11 +greyMatter = Short 0x12 +digidesign = Short 0x13 +palmTree = Short 0x14 +jlCooper = Short 0x15 +lowrey = Short 0x16 +adamsSmith = Short 0x17 +emu = Short 0x18 +harmony = Short 0x19 +art = Short 0x1A +baldwin = Short 0x1B +eventide = Short 0x1C +inventronics = Short 0x1D +keyConcepts = Short 0x1E +clarity = Short 0x1F + + +timeWarner = Extended 0x00 0x01 +digitalMusic = Extended 0x00 0x07 +iota = Extended 0x00 0x08 +newEngland = Extended 0x00 0x09 +artisyn = Extended 0x00 0x0A +ivl = Extended 0x00 0x0B +southernMusic = Extended 0x00 0x0C +lakeButler = Extended 0x00 0x0D +alesis = Extended 0x00 0x0E +dod = Extended 0x00 0x10 +studerEditech = Extended 0x00 0x11 +perfectFret = Extended 0x00 0x14 +kat = Extended 0x00 0x15 +opcode = Extended 0x00 0x16 +rane = Extended 0x00 0x17 +anadi = Extended 0x00 0x18 -- spatialSound ? +kmx = Extended 0x00 0x19 +brenell = Extended 0x00 0x1A +peavey = Extended 0x00 0x1B +systems360 = Extended 0x00 0x1C +spectrum = Extended 0x00 0x1D +marquis = Extended 0x00 0x1E +zeta = Extended 0x00 0x1F +axxes = Extended 0x00 0x20 +orban = Extended 0x00 0x21 +kti = Extended 0x00 0x24 +breakaway = Extended 0x00 0x25 +cae = Extended 0x00 0x26 +rocktron = Extended 0x00 0x29 +pianoDisc = Extended 0x00 0x2A +cannon = Extended 0x00 0x2B +rogers = Extended 0x00 0x2D +blueSkyLogic = Extended 0x00 0x2E +encore = Extended 0x00 0x2F +uptown = Extended 0x00 0x30 +voce = Extended 0x00 0x31 + +cti = Extended 0x00 0x32 +ssResearch = Extended 0x00 0x33 +broderbund = Extended 0x00 0x34 +allenOrgan = Extended 0x00 0x35 +musicQuest = Extended 0x00 0x37 +aphex = Extended 0x00 0x38 +gallienKrueger = Extended 0x00 0x39 +ibm = Extended 0x00 0x3A +hotzInstruments = Extended 0x00 0x3C +etaLighting = Extended 0x00 0x3D +nsi = Extended 0x00 0x3E +adLib = Extended 0x00 0x3F +richmond = Extended 0x00 0x40 +microsoft = Extended 0x00 0x41 +softwareToolworks = Extended 0x00 0x42 +rjmgNiche = Extended 0x00 0x43 +intone = Extended 0x00 0x44 +grooveTubes = Extended 0x00 0x47 +euphonix = Extended 0x00 0x4E +interMIDI = Extended 0x00 0x4F +loneWolf = Extended 0x00 0x55 +musonix = Extended 0x00 0x64 +taHorng = Extended 0x00 0x74 +eTek = Extended 0x00 0x75 -- formerly Forte +electrovoice = Extended 0x00 0x76 +midisoft = Extended 0x00 0x77 +qSoundLabs = Extended 0x00 0x78 +westrex = Extended 0x00 0x79 +nVidia = Extended 0x00 0x7A +ess = Extended 0x00 0x7B +mediaTrix = Extended 0x00 0x7C +brooktree = Extended 0x00 0x7D +otari = Extended 0x00 0x7E +keyElectronics = Extended 0x00 0x7F +crystalake = Extended 0x01 0x01 +crystal = Extended 0x01 0x02 +rockwell = Extended 0x01 0x03 +siliconGraphics = Extended 0x01 0x04 +midiman = Extended 0x01 0x05 +preSonus = Extended 0x01 0x06 +topaz = Extended 0x01 0x08 +castLighting = Extended 0x01 0x09 +microsoftConsumer = Extended 0x01 0x0A +fastForward = Extended 0x01 0x0C +headspace = Extended 0x01 0x0D -- Igor's Labs +vanKoevering = Extended 0x01 0x0E +altech = Extended 0x01 0x0F +-- ssResearch = Extended 0x01 0x10 +vlsi = Extended 0x01 0x11 +chromaticResearch = Extended 0x01 0x12 +sapphire = Extended 0x01 0x13 +idrc = Extended 0x01 0x14 +justonic = Extended 0x01 0x15 +torComp = Extended 0x01 0x16 +newtek = Extended 0x01 0x17 +soundSculpture = Extended 0x01 0x18 +walker = Extended 0x01 0x19 +pavo = Extended 0x01 0x1A +inVision = Extended 0x01 0x1B +tSquareDesign = Extended 0x01 0x1C +nemesys = Extended 0x01 0x1D +dbx = Extended 0x01 0x1E +syndyne = Extended 0x01 0x1F +bitheadz = Extended 0x01 0x20 +cakewalk = Extended 0x01 0x21 +staccato = Extended 0x01 0x22 +nationalSemiconductor = Extended 0x01 0x23 +boomTheory = Extended 0x01 0x24 -- Adinolfi Alternative Percussion +virtualDSP = Extended 0x01 0x25 +antares = Extended 0x01 0x26 +angelSoftware = Extended 0x01 0x27 +stLouis = Extended 0x01 0x28 +lyrrus = Extended 0x01 0x29 + + +-- * European Group +passac, siel, synthaxe, hohner, twister, solton, jellinghaus, + southworth, ppg, jen, ssl, audioVeritrieb, elka, dynacord, + viscount, clavia, audioArchitect, generalMusic, soundcraft, wersi, + avab, digigram, waldorf, quasimidi, + + dream, strandLighting, amek, drBohm, trident, realWorldDesign, + yesTechnology, audiomatica, bontempiFarfisa, fbtElectronica, miditemp, + larkingAudio, zero88lighting, miconAudio, forefront, kenton, adb, + jimMarshall, dda, bssAudio, tcElectronic, medeli, charlieLab, + blueChip, beeOH, lgSemiconductor, tesi, emagic, behringer, access, + synoptic, hanmesoft, terratec, proel, ibk + :: T + +passac = Short 0x20 +siel = Short 0x21 +synthaxe = Short 0x22 +hohner = Short 0x24 +twister = Short 0x25 +solton = Short 0x26 +jellinghaus = Short 0x27 +southworth = Short 0x28 +ppg = Short 0x29 +jen = Short 0x2A +ssl = Short 0x2B +audioVeritrieb = Short 0x2C +elka = Short 0x2F +dynacord = Short 0x30 +viscount = Short 0x31 +clavia = Short 0x33 +audioArchitect = Short 0x34 +generalMusic = Short 0x35 +soundcraft = Short 0x39 +wersi = Short 0x3B +avab = Short 0x3C +digigram = Short 0x3D +waldorf = Short 0x3E +quasimidi = Short 0x3F + +dream = Extended 0x20 0x00 +strandLighting = Extended 0x20 0x01 +amek = Extended 0x20 0x02 +drBohm = Extended 0x20 0x04 +trident = Extended 0x20 0x06 +realWorldDesign = Extended 0x20 0x07 +yesTechnology = Extended 0x20 0x09 +audiomatica = Extended 0x20 0x0A +bontempiFarfisa = Extended 0x20 0x0B +fbtElectronica = Extended 0x20 0x0C +miditemp = Extended 0x20 0x0D +larkingAudio = Extended 0x20 0x0E +zero88lighting = Extended 0x20 0x0F +miconAudio = Extended 0x20 0x10 +forefront = Extended 0x20 0x11 +kenton = Extended 0x20 0x13 +adb = Extended 0x20 0x15 +jimMarshall = Extended 0x20 0x16 +dda = Extended 0x20 0x17 +bssAudio = Extended 0x20 0x18 +tcElectronic = Extended 0x20 0x1F +medeli = Extended 0x20 0x2B +charlieLab = Extended 0x20 0x2C +blueChip = Extended 0x20 0x2D +beeOH = Extended 0x20 0x2E +lgSemiconductor = Extended 0x20 0x2F +tesi = Extended 0x20 0x30 +emagic = Extended 0x20 0x31 +behringer = Extended 0x20 0x32 +access = Extended 0x20 0x33 +synoptic = Extended 0x20 0x34 +hanmesoft = Extended 0x20 0x35 +terratec = Extended 0x20 0x36 +proel = Extended 0x20 0x37 +ibk = Extended 0x20 0x38 + + +-- * Japanese Group +kawai, roland, korg, yamaha, casio, kamiya, akai, japanVictor, + mesosha, hoshinoGakki, fujitsuElect, sony, nisshinOnpa, teac, + matsushitaElec, fostex, zoom, midori, matsushitaComm, suzuki + :: T + +kawai = Short 0x40 +roland = Short 0x41 +korg = Short 0x42 +yamaha = Short 0x43 +casio = Short 0x44 +kamiya = Short 0x46 +akai = Short 0x47 +japanVictor = Short 0x48 +mesosha = Short 0x49 +hoshinoGakki = Short 0x4A +fujitsuElect = Short 0x4B +sony = Short 0x4C +nisshinOnpa = Short 0x4D +teac = Short 0x4E +matsushitaElec = Short 0x50 +fostex = Short 0x51 +zoom = Short 0x52 +midori = Short 0x53 +matsushitaComm = Short 0x54 +suzuki = Short 0x55 + +-- * Universal ID Numbers +nonCommercial, nonRealTime, realTime :: T +nonCommercial = Short 0x7D +nonRealTime = Short 0x7E +realTime = Short 0x7F + + + + +-- * serialization + +get :: Parser.C parser => parser T +get = + do subId <- getByte + if subId == 0 + then liftM2 Extended getByte getByte + else return $ Short subId + +put :: Writer.C writer => T -> writer () +put subId = + case subId of + Short n -> Writer.putByte n + Extended hi lo -> + Writer.putByte 0 >> + Writer.putByte hi >> + Writer.putByte lo diff --git a/src/Sound/MIDI/Message.hs b/src/Sound/MIDI/Message.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message.hs @@ -0,0 +1,85 @@ +{- | +MIDI messages for real-time communication with MIDI devices. +This does not cover MIDI file events. +For these refer to "Sound.MIDI.File.Event". +-} +module Sound.MIDI.Message ( + T(..), + get, getWithStatus, getIncompleteWithStatus, + put, putWithStatus, + maybeFromByteString, toByteString, + ) where + +import qualified Sound.MIDI.Message.Channel as Channel +import qualified Sound.MIDI.Message.System as System + +import qualified Sound.MIDI.Parser.Status as StatusParser +import Sound.MIDI.Parser.Class (PossiblyIncomplete, ) +import qualified Sound.MIDI.Parser.Class as Parser +import Sound.MIDI.Parser.Primitive (get1) +import qualified Sound.MIDI.Parser.ByteString as ParserByteString + +import qualified Sound.MIDI.Writer.Status as StatusWriter +import qualified Sound.MIDI.Writer.Basic as Writer + +import qualified Sound.MIDI.Parser.Report as Report + +import Control.Monad.Trans (lift, ) +import Control.Monad (liftM, ) + +import qualified Data.ByteString.Lazy as B + +import Sound.MIDI.Utility (mapSnd, ) + + +data T = + Channel Channel.T + | System System.T + + +get :: Parser.C parser => parser T +get = + get1 >>= \code -> + if code >= 0xF0 + then liftM System $ System.get code + else liftM Channel $ (uncurry Channel.get (Channel.decodeStatus code) =<< get1) +-- else liftM Channel $ StatusParser.run (Channel.getWithStatus code) + +getWithStatus :: Parser.C parser => StatusParser.T parser T +getWithStatus = + StatusParser.lift get1 >>= \code -> + if code >= 0xF0 + then StatusParser.set Nothing >> + (liftM System $ StatusParser.lift $ System.get code) + else liftM Channel $ Channel.getWithStatus code + +getIncompleteWithStatus :: + Parser.C parser => StatusParser.T parser (PossiblyIncomplete T) +getIncompleteWithStatus = + StatusParser.lift get1 >>= \code -> + if code >= 0xF0 + then liftM (mapSnd System) $ StatusParser.lift $ System.getIncomplete code + else liftM ((,) Nothing . Channel) $ Channel.getWithStatus code + +maybeFromByteString :: B.ByteString -> Report.T T +maybeFromByteString = + ParserByteString.run get + + + + +put :: Writer.C writer => T -> writer () +put msg = + case msg of + Channel s -> Channel.put s + System s -> System.put s + +putWithStatus :: Writer.C writer => T -> StatusWriter.T writer () +putWithStatus msg = + case msg of + Channel s -> Channel.putWithStatus s + System s -> StatusWriter.clear >> lift (System.put s) + +toByteString :: T -> B.ByteString +toByteString = + Writer.runByteString . put diff --git a/src/Sound/MIDI/Message/Channel.hs b/src/Sound/MIDI/Message/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Channel.hs @@ -0,0 +1,125 @@ +{- | +Channel messages +-} +module Sound.MIDI.Message.Channel ( + T(..), Body(..), get, getWithStatus, put, putWithStatus, + Channel, fromChannel, toChannel, + + Voice.Pitch, Voice.fromPitch, Voice.toPitch, + Voice.Velocity, Voice.fromVelocity, Voice.toVelocity, + Voice.Program, Voice.fromProgram, Voice.toProgram, + Voice.Controller, Voice.fromController, Voice.toController, + + decodeStatus, + ) where + +import qualified Sound.MIDI.Message.Channel.Voice as Voice +import qualified Sound.MIDI.Message.Channel.Mode as Mode + +import qualified Sound.MIDI.Parser.Status as StatusParser +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser +import Sound.MIDI.Parser.Status + (lift, + Channel, fromChannel, toChannel, ) + +import Control.Monad (liftM, liftM2, when, ) + +import qualified Sound.MIDI.Writer.Status as StatusWriter +import qualified Sound.MIDI.Writer.Basic as Writer +import qualified Sound.MIDI.Bit as Bit + +import Sound.MIDI.Utility ({-checkRange,-} mapSnd, ) +-- import Data.Ix (Ix) + +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC + + + +data T = Cons { + messageChannel :: Channel, + messageBody :: Body + } + deriving (Show, Eq, Ord) + +data Body = + Voice Voice.T + | Mode Mode.T + deriving (Show, Eq, Ord) + +instance Arbitrary T where + arbitrary = + liftM2 Cons + (liftM toChannel $ QC.frequency $ + -- we have to prefer one favorite channel in order to test correct implementation of the running status + (20, return 3) : + ( 1, QC.choose (0,15)) : + []) + (QC.frequency $ + (20, liftM Voice arbitrary) : + ( 1, liftM Mode arbitrary) : + []) + coarbitrary = error "not implemented" + + +-- * serialization + +{- | +Parse an event. +Note that in the case of a regular MIDI Event, the tag is the status, +and we read the first byte of data before we call 'get'. +In the case of a MIDIEvent with running status, +we find out the status from the parser +(it's been nice enough to keep track of it for us), +and the tag that we've already gotten is the first byte of data. +-} +getWithStatus :: Parser.C parser => Int -> StatusParser.T parser T +getWithStatus tag = + do (status@(code, channel), firstData) <- + if tag < 0x80 + then maybe + (lift $ Parser.giveUp "messages wants to repeat status byte, but there was no status yet") + (\cc -> return (cc,tag)) + =<< StatusParser.get + else liftM ((,) $ decodeStatus tag) $ lift get1 + StatusParser.set (Just status) + lift $ get code channel firstData + +-- | for internal use +decodeStatus :: Int -> (Int, Channel) +decodeStatus = mapSnd toChannel . Bit.splitAt 4 + +{- | +Parse a MIDI Channel message. +Note that since getting the first byte is a little complex +(there are issues with running status), +the code, channel and first data byte +must be determined by the caller. +-} +get :: Parser.C parser => Int -> Channel -> Int -> parser T +get code channel firstData = + liftM (Cons channel) $ + if code == 11 && firstData >= 0x78 + then + when (firstData >= 0x80) + (Parser.giveUp ("mode value out of range: " ++ show firstData)) >> + liftM Mode (Mode.get firstData) + else liftM Voice (Voice.get code firstData) + + +put :: Writer.C writer => T -> writer () +put = StatusWriter.toWriterWithoutStatus . putWithStatus + +putWithStatus :: Writer.C writer => T -> StatusWriter.T writer () +putWithStatus (Cons c e) = + case e of + Voice v -> Voice.putWithStatus (putChannel c) v + Mode m -> putChannel c 11 >> lift (Mode.put m) + +-- | output a channel + message code +putChannel :: Writer.C writer => Channel -> Int -> StatusWriter.T writer () +putChannel chan code = + do b <- StatusWriter.change (Just (code, chan)) + when b $ lift $ + Writer.putIntAsByte (16*code + fromChannel chan) diff --git a/src/Sound/MIDI/Message/Channel/Mode.hs b/src/Sound/MIDI/Message/Channel/Mode.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Channel/Mode.hs @@ -0,0 +1,107 @@ +{- | +Channel mode messages +-} +module Sound.MIDI.Message.Channel.Mode + (T(..), get, put, + fromControllerValue, toControllerValue, ) where + +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser + +import qualified Sound.MIDI.Writer.Basic as Writer + +import Sound.MIDI.Parser.Report (UserMessage, ) + +import Sound.MIDI.Utility (toMaybe, ) + +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC + +import Control.Monad (liftM, ) + + +data T = + AllSoundOff + | ResetAllControllers + | LocalControl Bool + | AllNotesOff + | OmniMode Bool + | MonoMode Int + | PolyMode + deriving (Show, Eq, Ord) + +instance Arbitrary T where + arbitrary = + QC.oneof $ + return AllSoundOff : + return ResetAllControllers : + liftM LocalControl arbitrary : + return AllNotesOff : + liftM OmniMode arbitrary : + liftM MonoMode (QC.choose (0,16)) : + return PolyMode : + [] + coarbitrary = error "not implemented" + + +-- * serialization + +get :: Parser.C parser => Int -> parser T +get mode = + do x <- get1 + let (w, msg) = fromControllerValue (mode,x) + maybe (return ()) Parser.warn w + return msg + +fromControllerValue :: Integral a => (a, a) -> (Maybe UserMessage, T) +fromControllerValue (mode,x) = + case mode of + 0x78 -> + (checkValidValue "AllSoundOff" [0] x, + AllSoundOff) + 0x79 -> + (checkValidValue "ResetAllControllers" [0] x, + ResetAllControllers) + 0x7A -> + (checkValidValue "LocalControl" [0,127] x, + LocalControl (x/=0)) + 0x7B -> + (checkValidValue "AllNotesOff" [0] x, + AllNotesOff) + 0x7C -> + (checkValidValue "OmniMode Off" [0] x, + OmniMode False) + 0x7D -> + (checkValidValue "OmniMode On" [0] x, + OmniMode True) + 0x7E -> + (Nothing, MonoMode (fromIntegral x)) + 0x7F -> + (checkValidValue "PolyMode On" [0] x, + PolyMode) + _ -> error ("Channel.Mode.get: mode value out of range: " ++ show mode) + + +checkValidValue :: + Integral a => String -> [a] -> a -> Maybe UserMessage +checkValidValue name validValues value = + toMaybe + (not (elem value validValues)) + ("Invalid value for " ++ name ++ ": " ++ show value) + + +put :: Writer.C writer => T -> writer () +put mode = + let (code, value) = toControllerValue mode + in Writer.putByteList [code, value] + +toControllerValue :: Integral a => T -> (a, a) +toControllerValue mode = + case mode of + AllSoundOff -> (,) 0x78 0 + ResetAllControllers -> (,) 0x79 0 + LocalControl b -> (,) 0x7A (if b then 127 else 0) + AllNotesOff -> (,) 0x7B 0 + OmniMode b -> (,) (if b then 0x7D else 0x7C) 0 + MonoMode x -> (,) 0x7E (fromIntegral x) + PolyMode -> (,) 0x7F 0 diff --git a/src/Sound/MIDI/Message/Channel/Voice.hs b/src/Sound/MIDI/Message/Channel/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Channel/Voice.hs @@ -0,0 +1,441 @@ +{- | +Channel voice messages +-} +module Sound.MIDI.Message.Channel.Voice ( + T(..), get, putWithStatus, + ControllerValue, PitchBendRange, Pressure, + isNote, isNoteOn, isNoteOff, zeroKey, + explicitNoteOff, implicitNoteOff, + toFloatController, + + bankSelect, modulation, breathControl, footControl, portamentoTime, + dataEntry, mainVolume, balance, panorama, expression, + generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, + vectorX, vectorY, + + bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, + portamentoTimeMSB, dataEntryMSB, mainVolumeMSB, balanceMSB, + panoramaMSB, expressionMSB, generalPurpose1MSB, generalPurpose2MSB, + generalPurpose3MSB, generalPurpose4MSB, bankSelectLSB, modulationLSB, + breathControlLSB, footControlLSB, portamentoTimeLSB, dataEntryLSB, + mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB, + generalPurpose1LSB, generalPurpose2LSB, generalPurpose3LSB, generalPurpose4LSB, + + sustain, porta, sustenuto, softPedal, hold2, + generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, + extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth, + + dataIncrement, dataDecrement, + nonRegisteredParameterLSB, nonRegisteredParameterMSB, + registeredParameterLSB, registeredParameterMSB, + + Pitch, fromPitch, toPitch, + Velocity, fromVelocity, toVelocity, + Program, fromProgram, toProgram, + Controller, fromController, toController, + + increasePitch, subtractPitch, + maximumVelocity, normalVelocity, toFloatVelocity, + ) where + +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser + +import Control.Monad (liftM, liftM2, ) + +import qualified Sound.MIDI.Writer.Status as StatusWriter +import qualified Sound.MIDI.Writer.Basic as Writer +import qualified Sound.MIDI.Bit as Bit + +import Data.Ix (Ix) +import Sound.MIDI.Utility (checkRange, + quantityRandomR, boundedQuantityRandom, chooseQuantity, + enumRandomR, boundedEnumRandom, chooseEnum, ) + +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC +import System.Random (Random(random, randomR), ) + + + +-- * message type + +data T = + NoteOff Pitch Velocity + | NoteOn Pitch Velocity + | PolyAftertouch Pitch Pressure + | ProgramChange Program + | Control Controller ControllerValue + | PitchBend PitchBendRange + | MonoAftertouch Pressure + deriving (Show, Eq, Ord) + + +instance Arbitrary T where + arbitrary = + QC.frequency $ + (10, liftM2 NoteOff arbitrary arbitrary) : + (10, liftM2 NoteOn arbitrary arbitrary) : + ( 1, liftM2 PolyAftertouch arbitrary (QC.choose (0,127))) : + ( 1, liftM ProgramChange arbitrary) : + ( 1, liftM2 Control arbitrary (QC.choose (0,127))) : + ( 1, liftM PitchBend (QC.choose (0,12))) : + ( 1, liftM MonoAftertouch (QC.choose (0,127))) : + [] + coarbitrary = error "not implemented" + + +instance Random Pitch where + random = boundedEnumRandom + randomR = enumRandomR + +instance Arbitrary Pitch where + arbitrary = chooseEnum + coarbitrary = error "not implemented" + + +instance Random Velocity where + random = boundedQuantityRandom fromVelocity toVelocity + randomR = quantityRandomR fromVelocity toVelocity + +instance Arbitrary Velocity where + arbitrary = chooseQuantity fromVelocity toVelocity + coarbitrary = error "not implemented" + + +instance Random Program where + random = boundedEnumRandom + randomR = enumRandomR + +instance Arbitrary Program where + arbitrary = chooseEnum + coarbitrary = error "not implemented" + + +instance Random Controller where + random = boundedEnumRandom + randomR = enumRandomR + +instance Arbitrary Controller where + arbitrary = chooseEnum + coarbitrary = error "not implemented" + + +isNote :: T -> Bool +isNote (NoteOn _ _) = True +isNote (NoteOff _ _) = True +isNote _ = False + +{- | +NoteOn with zero velocity is considered NoteOff according to MIDI specification. +-} +isNoteOn :: T -> Bool +isNoteOn (NoteOn _ v) = v > toVelocity 0 +isNoteOn _ = False + +{- | +NoteOn with zero velocity is considered NoteOff according to MIDI specification. +-} +isNoteOff :: T -> Bool +isNoteOff (NoteOn _ v) = v == toVelocity 0 +isNoteOff (NoteOff _ _) = True +isNoteOff _ = False + + +{- | +Convert all @NoteOn p 0@ to @NoteOff p 64@. +The latter one is easier to process. +-} +explicitNoteOff :: T -> T +explicitNoteOff msg = + case msg of + NoteOn p v -> + if v == toVelocity 0 + then NoteOff p $ toVelocity 64 + else msg + _ -> msg + + +{- | +Convert all @NoteOff p 64@ to @NoteOn p 0@. +The latter one can be encoded more efficiently using the running status. +-} +implicitNoteOff :: T -> T +implicitNoteOff msg = + case msg of + NoteOff p v -> + if v == toVelocity 64 + then NoteOn p $ toVelocity 0 + else msg + _ -> msg + + + + +-- * Primitive types in Voice messages + +type PitchBendRange = Int +type Pressure = Int +type ControllerValue = Int + + +newtype Pitch = Pitch {fromPitch :: Int} deriving (Show, Eq, Ord, Ix) +newtype Velocity = Velocity {fromVelocity :: Int} deriving (Show, Eq, Ord) +newtype Program = Program {fromProgram :: Int} deriving (Show, Eq, Ord, Ix) + +{- | +We do not define 'Controller' as enumeration with many constructors, +because some controller have multiple names and some are undefined. +It is also more efficient this way. +Thus you cannot use @case@ for processing controller types, +but you can use 'Data.List.lookup' instead. + +> maybe (putStrLn "unsupported controller") putStrLn $ +> lookup ctrl $ +> (portamento, "portamento") : +> (modulation, "modulation") : +> [] + +-} +newtype Controller = Controller {fromController :: Int} deriving (Show, Eq, Ord, Ix) + +toPitch :: Int -> Pitch +toPitch = checkRange "Pitch" Pitch + +toVelocity :: Int -> Velocity +toVelocity = checkRange "Velocity" Velocity + +toProgram :: Int -> Program +toProgram = checkRange "Program" Program + +toController :: Int -> Controller +toController = checkRange "Controller" Controller + + +instance Enum Pitch where + toEnum = toPitch + fromEnum = fromPitch + +{- +I do not like an Enum Velocity instance, +because Velocity is an artificially sampled continuous quantity. +-} + +instance Enum Program where + toEnum = toProgram + fromEnum = fromProgram + +instance Enum Controller where + toEnum = toController + fromEnum = fromController + +-- typical methods of a type class for affine spaces +increasePitch :: Int -> Pitch -> Pitch +increasePitch d = toPitch . (d+) . fromPitch + +subtractPitch :: Pitch -> Pitch -> Int +subtractPitch (Pitch p0) (Pitch p1) = p1-p0 + + +instance Bounded Pitch where + minBound = Pitch 0 + maxBound = Pitch 127 + +instance Bounded Velocity where + minBound = Velocity 0 + maxBound = Velocity 127 + +instance Bounded Program where + minBound = Program 0 + maxBound = Program 127 + +instance Bounded Controller where + minBound = Controller 0 + maxBound = Controller 119 + + +{- | +A MIDI problem is that one cannot uniquely map +a MIDI key to a frequency. +The frequency depends on the instrument. +I don't know if the deviations are defined for General MIDI. +If this applies one could add transposition information +to the use patch map. +For now I have chosen a value that leads to the right frequency +for some piano sound in my setup. +-} + +zeroKey :: Pitch +zeroKey = toPitch 48 + +{- | +The velocity of an ordinary key stroke and +the maximum possible velocity. +-} + +normalVelocity, maximumVelocity :: Num quant => quant + -- Velocity +normalVelocity = 64 +maximumVelocity = 127 + +{- | +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. +-} +toFloatVelocity :: (Integral a, Fractional b) => a -> b +toFloatVelocity x = fromIntegral x / normalVelocity + +maximumControllerValue :: Num quant => quant +maximumControllerValue = 127 + +{- | +Map integral MIDI controller value to floating point value. +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 + + + +-- * predefined MIDI controllers + + +-- ** simple names for controllers, if only most-significant bytes are used + +bankSelect, modulation, breathControl, footControl, portamentoTime, + dataEntry, mainVolume, balance, panorama, expression, + generalPurpose1, generalPurpose2, generalPurpose3, generalPurpose4, + vectorX, vectorY :: Controller +bankSelect = bankSelectMSB +modulation = modulationMSB +breathControl = breathControlMSB +footControl = footControlMSB +portamentoTime = portamentoTimeMSB +dataEntry = dataEntryMSB +mainVolume = mainVolumeMSB +balance = balanceMSB +panorama = panoramaMSB +expression = expressionMSB +generalPurpose1 = generalPurpose1MSB +generalPurpose2 = generalPurpose2MSB +generalPurpose3 = generalPurpose3MSB +generalPurpose4 = generalPurpose4MSB + +vectorX = generalPurpose1 +vectorY = generalPurpose2 + + + +-- ** controllers for most-significant bytes of control values +bankSelectMSB, modulationMSB, breathControlMSB, footControlMSB, + portamentoTimeMSB, dataEntryMSB, + mainVolumeMSB, balanceMSB, panoramaMSB, expressionMSB, + generalPurpose1MSB, generalPurpose2MSB, + generalPurpose3MSB, generalPurpose4MSB :: Controller + +-- ** controllers for least-significant bytes of control values +bankSelectLSB, modulationLSB, breathControlLSB, footControlLSB, + portamentoTimeLSB, dataEntryLSB, + mainVolumeLSB, balanceLSB, panoramaLSB, expressionLSB, + generalPurpose1LSB, generalPurpose2LSB, + generalPurpose3LSB, generalPurpose4LSB :: Controller + +-- ** additional single byte controllers +sustain, porta, sustenuto, softPedal, hold2, + generalPurpose5, generalPurpose6, generalPurpose7, generalPurpose8, + extDepth, tremoloDepth, chorusDepth, celesteDepth, phaserDepth :: Controller + +-- ** increment/decrement and parameter numbers +dataIncrement, dataDecrement, + nonRegisteredParameterLSB, nonRegisteredParameterMSB, + registeredParameterLSB, registeredParameterMSB :: Controller + + +bankSelectMSB = toEnum 0x00 {- 00 00 -} +modulationMSB = toEnum 0x01 {- 01 01 -} +breathControlMSB = toEnum 0x02 {- 02 02 -} +footControlMSB = toEnum 0x04 {- 04 04 -} +portamentoTimeMSB = toEnum 0x05 {- 05 05 -} +dataEntryMSB = toEnum 0x06 {- 06 06 -} +mainVolumeMSB = toEnum 0x07 {- 07 07 -} +balanceMSB = toEnum 0x08 {- 08 08 -} +panoramaMSB = toEnum 0x0A {- 10 0A -} +expressionMSB = toEnum 0x0B {- 11 0B -} +generalPurpose1MSB = toEnum 0x10 {- 16 10 -} +generalPurpose2MSB = toEnum 0x11 {- 17 11 -} +generalPurpose3MSB = toEnum 0x12 {- 18 12 -} +generalPurpose4MSB = toEnum 0x13 {- 19 13 -} + +bankSelectLSB = toEnum 0x20 {- 32 20 -} +modulationLSB = toEnum 0x21 {- 33 21 -} +breathControlLSB = toEnum 0x22 {- 34 22 -} +footControlLSB = toEnum 0x24 {- 36 24 -} +portamentoTimeLSB = toEnum 0x25 {- 37 25 -} +dataEntryLSB = toEnum 0x26 {- 38 26 -} +mainVolumeLSB = toEnum 0x27 {- 39 27 -} +balanceLSB = toEnum 0x28 {- 40 28 -} +panoramaLSB = toEnum 0x2A {- 42 2A -} +expressionLSB = toEnum 0x2B {- 43 2B -} +generalPurpose1LSB = toEnum 0x30 {- 48 30 -} +generalPurpose2LSB = toEnum 0x31 {- 49 31 -} +generalPurpose3LSB = toEnum 0x32 {- 50 32 -} +generalPurpose4LSB = toEnum 0x33 {- 51 33 -} + +sustain = toEnum 0x40 {- 64 40 -} +porta = toEnum 0x41 {- 65 41 -} +sustenuto = toEnum 0x42 {- 66 42 -} +softPedal = toEnum 0x43 {- 67 43 -} +hold2 = toEnum 0x45 {- 69 45 -} +generalPurpose5 = toEnum 0x50 {- 80 50 -} +generalPurpose6 = toEnum 0x51 {- 81 51 -} +generalPurpose7 = toEnum 0x52 {- 82 52 -} +generalPurpose8 = toEnum 0x53 {- 83 53 -} +extDepth = toEnum 0x5B {- 91 5B -} +tremoloDepth = toEnum 0x5C {- 92 5C -} +chorusDepth = toEnum 0x5D {- 93 5D -} +celesteDepth = toEnum 0x5E {- 94 5E -} +phaserDepth = toEnum 0x5F {- 95 5F -} + +dataIncrement = toEnum 0x60 {- 96 60 -} +dataDecrement = toEnum 0x61 {- 97 61 -} +nonRegisteredParameterLSB = toEnum 0x62 {- 98 62 -} +nonRegisteredParameterMSB = toEnum 0x63 {- 99 63 -} +registeredParameterLSB = toEnum 0x64 {- 100 64 -} +registeredParameterMSB = toEnum 0x65 {- 101 65 -} + + +-- * serialization + +get :: Parser.C parser => Int -> Int -> parser T +get code firstData = + let pitch = toPitch firstData + getVel = liftM toVelocity get1 + in case code of + 08 -> liftM (NoteOff pitch) getVel + 09 -> liftM (NoteOn pitch) getVel + 10 -> liftM (PolyAftertouch pitch) get1 + 11 -> liftM (Control (toEnum firstData)) get1 + 12 -> return (ProgramChange (toProgram firstData)) + 13 -> return (MonoAftertouch firstData) + 14 -> liftM (\msb -> PitchBend (firstData+128*msb)) get1 + _ -> Parser.giveUp ("invalid Voice message code:" ++ show code) + + +putWithStatus :: Writer.C writer => + (Int -> StatusWriter.T writer ()) -> T -> StatusWriter.T writer () +putWithStatus putChan e = + let putC code bytes = + putChan code >> + StatusWriter.fromWriter (Writer.putByteList (map fromIntegral bytes)) + in case e of + NoteOff p v -> putC 8 [fromPitch p, fromVelocity v] + NoteOn p v -> putC 9 [fromPitch p, fromVelocity v] + PolyAftertouch p pr -> putC 10 [fromPitch p, pr] + Control cn cv -> putC 11 [fromEnum cn, cv] + ProgramChange pn -> putC 12 [fromProgram pn] + MonoAftertouch pr -> putC 13 [pr] + PitchBend pb -> + let (hi,lo) = Bit.splitAt 7 pb in putC 14 [lo,hi] -- little-endian!! diff --git a/src/Sound/MIDI/Message/System.hs b/src/Sound/MIDI/Message/System.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/System.hs @@ -0,0 +1,59 @@ +{- | +System messages +-} +module Sound.MIDI.Message.System ( + T(..), get, getIncomplete, put, + ) where + +import qualified Sound.MIDI.Message.System.Exclusive as Exclusive +import qualified Sound.MIDI.Message.System.Common as Common +import qualified Sound.MIDI.Message.System.RealTime as RealTime + +-- import Sound.MIDI.Parser.Primitive +import Sound.MIDI.Parser.Class (PossiblyIncomplete, ) +import qualified Sound.MIDI.Parser.Class as Parser + +import qualified Sound.MIDI.Writer.Basic as Writer + +import Control.Monad (liftM, ) + +import Sound.MIDI.Utility (mapSnd, ) + + +data T = + Exclusive Exclusive.T + | Common Common.T + | RealTime RealTime.T + + +get :: Parser.C parser => Int -> parser T +get code = + if code == 0xF0 + then liftM Exclusive Exclusive.get + else + if code >= 0xF1 && code <= 0xF6 + then liftM Common $ Common.get code + else + if code >= 0xF8 && code <= 0xFF + then liftM RealTime $ RealTime.get code + else Parser.giveUp ("invalid System message code " ++ show code) + +getIncomplete :: Parser.C parser => Int -> parser (PossiblyIncomplete T) +getIncomplete code = + if code == 0xF0 + then liftM (mapSnd Exclusive) Exclusive.getIncomplete + else + if code >= 0xF1 && code <= 0xF6 + then liftM ((,) Nothing . Common) $ Common.get code + else + if code >= 0xF8 && code <= 0xFF + then liftM ((,) Nothing . RealTime) $ RealTime.get code + else Parser.giveUp ("invalid System message code " ++ show code) + + +put :: Writer.C writer => T -> writer () +put msg = + case msg of + Exclusive s -> Exclusive.put s + Common s -> Common.put s + RealTime s -> RealTime.put s diff --git a/src/Sound/MIDI/Message/System/Common.hs b/src/Sound/MIDI/Message/System/Common.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/System/Common.hs @@ -0,0 +1,71 @@ +{- | +System Common messages +-} +module Sound.MIDI.Message.System.Common ( + T(..), TimeNibbleType(..), get, put, + ) where + +import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser + +import Control.Monad (liftM, liftM2, when, ) + +import qualified Sound.MIDI.Writer.Basic as Writer + +import qualified Sound.MIDI.Bit as Bit + +import Data.Ix(Ix) + + +data T = + TimeCodeQuarterFrame TimeNibbleType Int + | SongPositionPointer Int + | SongSelect Int + | TuneRequest +-- | EndOfSystemExclusive + +data TimeNibbleType = + FrameLS + | FrameMS + | SecondsLS + | SecondsMS + | MinutesLS + | MinutesMS + | HoursLS + | HoursMS -- ^ also includes SMPTE type + deriving (Eq, Ord, Show, Enum, Ix) + + +-- * serialization + +get :: Parser.C parser => Int -> parser T +get code = + case code of + 0xF1 -> + do dat <- get1 + let (nib, value) = Bit.splitAt 4 dat + let (msb, nibble) = Bit.splitAt 3 nib + when (msb/=0) + (Parser.warn "TimeCodeQuarterFrame: most significant bit must 0") + return $ TimeCodeQuarterFrame (toEnum nibble) value + 0xF2 -> liftM2 (\lsb msb -> SongPositionPointer (lsb + Bit.shiftL 7 msb)) get1 get1 + 0xF3 -> liftM SongSelect get1 + 0xF6 -> return TuneRequest + _ -> Parser.giveUp ("invalid System Common code:" ++ show code) + +put :: Writer.C writer => T -> writer () +put msg = + case msg of + TimeCodeQuarterFrame nibble value -> + Writer.putByte 0xF1 >> + Writer.putIntAsByte (Bit.shiftL 4 (fromEnum nibble) + value) + SongPositionPointer pos -> + Writer.putByte 0xF2 >> + let (msb,lsb) = Bit.splitAt 7 pos + in Writer.putIntAsByte lsb >> + Writer.putIntAsByte msb + SongSelect song -> + Writer.putByte 0xF3 >> + Writer.putIntAsByte song + TuneRequest -> + Writer.putByte 0xF6 diff --git a/src/Sound/MIDI/Message/System/Exclusive.hs b/src/Sound/MIDI/Message/System/Exclusive.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/System/Exclusive.hs @@ -0,0 +1,76 @@ +{- | +System Exclusive messages +-} +module Sound.MIDI.Message.System.Exclusive ( + T(..), get, getIncomplete, put, + ) where + +import qualified Sound.MIDI.Manufacturer as Manufacturer +import Sound.MIDI.IO (ByteList) + +import Sound.MIDI.Parser.Primitive +import Sound.MIDI.Parser.Class (PossiblyIncomplete, ) +import qualified Sound.MIDI.Parser.Class as Parser + +import qualified Sound.MIDI.Writer.Basic as Writer + +-- import Control.Monad (liftM, liftM2, when, ) + +import Data.Maybe (fromMaybe, ) + + +data T = + Commercial Manufacturer.T ByteList + | NonCommercial ByteList + | NonRealTime NonRealTime + | RealTime RealTime + + +-- * Non-real time + +{-# DEPRECATED NonRealTime "structure must be defined, yet" #-} +newtype NonRealTime = NonRealTimeCons ByteList + +-- * Real time + +{-# DEPRECATED RealTime "structure must be defined, yet" #-} +newtype RealTime = RealTimeCons ByteList + + +-- * serialization + +get :: Parser.C parser => parser T +get = + do (err, sysex) <- getIncomplete + maybe (return sysex) Parser.giveUp err + +getIncomplete :: Parser.C parser => parser (PossiblyIncomplete T) +getIncomplete = + do manu <- Manufacturer.get + (err, body) <- Parser.until (0xf7 ==) getByte + return $ ((,) err) $ + fromMaybe (Commercial manu body) $ + lookup manu $ + (Manufacturer.nonCommercial, NonCommercial body) : + (Manufacturer.nonRealTime, NonRealTime $ NonRealTimeCons body) : + (Manufacturer.realTime, RealTime $ RealTimeCons body) : + [] + +{- | +It is not checked whether SysEx messages contain only 7-bit values. +-} +put :: Writer.C writer => T -> writer () +put sysex = + case sysex of + Commercial manu body -> + Manufacturer.put manu >> + Writer.putByteList body + NonCommercial body -> + Manufacturer.put Manufacturer.nonCommercial >> + Writer.putByteList body + NonRealTime (NonRealTimeCons body) -> + Manufacturer.put Manufacturer.nonRealTime >> + Writer.putByteList body + RealTime (RealTimeCons body) -> + Manufacturer.put Manufacturer.realTime >> + Writer.putByteList body diff --git a/src/Sound/MIDI/Message/System/RealTime.hs b/src/Sound/MIDI/Message/System/RealTime.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/System/RealTime.hs @@ -0,0 +1,47 @@ +{- | +System Real Time messages +-} +module Sound.MIDI.Message.System.RealTime ( + T(..), get, put, + ) where + +-- import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.Parser.Class as Parser + +import qualified Sound.MIDI.Writer.Basic as Writer + +import Data.Ix(Ix) + + +data T = + TimingClock -- F8 + | Start -- FA + | Continue -- FB + | Stop -- FC + | ActiveSensing -- FE + | Reset -- FF + deriving (Eq, Ord, Show, Enum, Ix) + + +-- * serialization + +get :: Parser.C parser => Int -> parser T +get code = + case code of + 0xF8 -> return TimingClock + 0xFA -> return Start + 0xFB -> return Continue + 0xFC -> return Stop + 0xFE -> return ActiveSensing + 0xFF -> return Reset + _ -> Parser.giveUp ("unknown System Real Time message code " ++ show code) + +put :: Writer.C writer => T -> writer () +put msg = + case msg of + TimingClock -> Writer.putByte 0xF8 + Start -> Writer.putByte 0xFA + Continue -> Writer.putByte 0xFB + Stop -> Writer.putByte 0xFC + ActiveSensing -> Writer.putByte 0xFE + Reset -> Writer.putByte 0xFF diff --git a/src/Sound/MIDI/Parser.hs b/src/Sound/MIDI/Parser.hs deleted file mode 100644 --- a/src/Sound/MIDI/Parser.hs +++ /dev/null @@ -1,32 +0,0 @@ -{- | -Taken from Haskore. --} - -module Sound.MIDI.Parser - (T, zeroOrMore, oneOrMore, StateT(..), force, ) where - -import Control.Monad.State (StateT(StateT, runStateT), liftM2, mplus, ) -import Control.Monad.Error () - -type T s = StateT s (Either String) - - -{- | -Wadler's force function - -'force' guarantees that the parser does not fail. -Thus it makes parsing more lazy. -However if the original parser fails though, -then we get an unrecoverable /irrefutable pattern/ error on 'Just'. --} -force :: T s a -> T s a -force p = - StateT $ \ s -> - let Right x = runStateT p s - in Right x - -zeroOrMore :: T s a -> T s [a] -zeroOrMore p = force $ oneOrMore p `mplus` return [] - -oneOrMore :: T s a -> T s [a] -oneOrMore p = liftM2 (:) p (zeroOrMore p) diff --git a/src/Sound/MIDI/Parser/ByteString.hs b/src/Sound/MIDI/Parser/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/ByteString.hs @@ -0,0 +1,129 @@ +{- +This module Sound.MIDI.Parser.Stream share significant portions of code. +-} +module Sound.MIDI.Parser.ByteString + (T(..), run, runIncomplete, {- runPartial, -} + PossiblyIncomplete, UserMessage, ) where + + +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary.Get as Binary +import Data.Binary.Get (Get, runGet, ) + +import Control.Monad (liftM, when, ) + +import qualified Sound.MIDI.Parser.Class as Parser +import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) +import qualified Sound.MIDI.Parser.Report as Report + +-- import Data.Word (Word8) + +import Data.Int (Int64) +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Prelude hiding (replicate, until, ) + + + +newtype T a = Cons {decons :: Get (Report.T a)} + + +{- +runPartial :: T a -> B.ByteString -> (Report.T a, B.ByteString) +runPartial parser input = + flip runGetState input (decons parser) +-} + + +run :: T a -> B.ByteString -> Report.T a +run parser input = + flip runGet input $ decons $ + (do a <- parser + end <- Parser.isEnd + when (not end) (warn "unparsed data left over") + return a) + +{- | +Treat errors which caused an incomplete data structure as warnings. +This is reasonable, because we do not reveal the remaining unparsed data +and thus further parsing is not possible. +-} +runIncomplete :: + T (PossiblyIncomplete a) -> B.ByteString -> Report.T a +runIncomplete parser input = + flip run input $ + do (me,x) <- parser + maybe (return ()) warn me + return x + + +fromGet :: Get a -> T a +fromGet p = + Cons $ liftM (\a -> Report.Cons [] (Right a)) p + + +instance Monad T where + return x = fromGet $ return x + x >>= y = Cons $ + decons x >>= \ a -> + case Report.result a of + Left err -> return (Report.Cons (Report.warnings a) (Left err)) + Right ar -> + decons (y ar) >>= \ b -> + return (b{Report.warnings = Report.warnings a ++ Report.warnings b}) + +instance Parser.C T where + isEnd = fromGet Binary.isEmpty +-- getByte = fromGet Binary.getWord8 +-- a get getMabybeWord8 would be nice in order to avoid double-checking + getByte = + do end <- fromGet Binary.isEmpty + if end + then giveUp "unexpected end of ByteString" + else fromGet Binary.getWord8 + skip n = + let toSize x = + let y = if x > fromIntegral (maxBound `asTypeOf` y) + then error "skip: number too big" + else fromIntegral x + in y + in fromGet $ skip $ toSize $ NonNeg.toNumber n + warn = warn + giveUp = giveUp + try = try + force = force + +{- | +In contrast to Binary.skip this one does not fail badly and it works with Int64. +I hope that it is not too inefficient. +-} +skip :: Int64 -> Get () +skip n = Binary.getLazyByteString n >> return () +-- Binary.skip n + +warn :: String -> T () +warn text = + Cons $ return $ Report.Cons [text] (Right ()) + +giveUp :: String -> T a +giveUp text = + Cons $ return $ Report.Cons [] (Left text) + +try :: T a -> T (Either UserMessage a) +try = + Cons . liftM (\r -> r{Report.result = Right (Report.result r)}) . decons + + +{- | +Wadler's force function + +'force' guarantees that the parser does not fail. +Thus it makes parsing more lazy. +However if the original parser fails though, +then we get an unrecoverable /irrefutable pattern/ error on 'Just'. +-} +force :: T a -> T a +force p = + Cons $ + do ~(Report.Cons w ~(Right x)) <- decons p + return (Report.Cons w (Right x)) diff --git a/src/Sound/MIDI/Parser/Class.hs b/src/Sound/MIDI/Parser/Class.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/Class.hs @@ -0,0 +1,156 @@ +module Sound.MIDI.Parser.Class + (C, isEnd, getByte, + warn, giveUp, try, + force, zeroOrMore, zeroOrMoreInc, until, replicate, skip, + PossiblyIncomplete, UserMessage, + {- for debugging + handleMsg, appendIncomplete, + -} + ) where + + +import Sound.MIDI.Parser.Report (UserMessage) + +import Control.Monad (liftM, liftM2, ) + +import Data.Word (Word8) + +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Sound.MIDI.Utility (mapSnd, ) + +import Prelude hiding (replicate, until, ) + + + +class Monad parser => C parser where + isEnd :: parser Bool + getByte :: parser Word8 + skip :: NonNeg.Integer -> parser () + warn :: UserMessage -> parser () + giveUp :: UserMessage -> parser a + try :: parser a -> parser (Either UserMessage a) + force :: parser a -> parser a + + + +{- | +@PossiblyIncomplete@ represents a value like a list +that can be the result of an incomplete parse. +The case of an incomplete parse is indicated by @Just message@. + +It is not possible to merge this functionality in the parser monad, +because then it is not possible to define monadic binding. + +In the future it should be replaced by +'Control.Monad.Exception.Asynchronous.Exceptional' +from the explicit-exception package. +-} +type PossiblyIncomplete a = (Maybe UserMessage, a) + + + +{- +zeroOrMore :: T s a -> T s [a] +zeroOrMore p = force $ oneOrMore p `mplus` return [] + +oneOrMore :: T s a -> T s [a] +oneOrMore p = liftM2 (:) p (zeroOrMore p) +-} + +{- | +This function will never fail. +If the element parser fails somewhere, +a prefix of the complete list is returned +along with the error message. +-} +zeroOrMore :: C parser => + parser a -> parser (PossiblyIncomplete [a]) +zeroOrMore p = + let go = + force $ isEnd >>= \b -> + if b + then return (Nothing, []) + else handleMsg + (\errMsg -> (Just errMsg, [])) + (liftM2 (\ x ~(e,xs) -> (e,x:xs)) p go) + in go + + +zeroOrMoreInc :: C parser => + parser (PossiblyIncomplete a) -> parser (PossiblyIncomplete [a]) +zeroOrMoreInc p = + let go = + force $ isEnd >>= \b -> + if b + then return (Nothing, []) + else handleMsg + (\errMsg -> (Just errMsg, [])) + (appendIncomplete p go) + in go + + +{- | +Parse until an element is found, which matches a condition. +The terminating element is consumed by the parser +but not appended to the result list. +If the end of the input is reached without finding the terminating element, +then an Incomplete exception (Just errorMessage) is signalled. +-} +until :: C parser => + (a -> Bool) -> parser a -> parser (PossiblyIncomplete [a]) +until c p = + let go = + force $ isEnd >>= \b -> + if b + then + return (Just "Parser.until: unexpected end of input", []) + else + handleMsg + (\errMsg -> (Just errMsg, [])) $ + p >>= \x -> + if c x + then return (Nothing, []) + else liftM (mapSnd (x:)) go + in go + + +{- | +This function will never fail. +It may however return a list that is shorter than requested. +-} +replicate :: + C parser => + NonNeg.Int -> + parser (PossiblyIncomplete a) -> + parser (PossiblyIncomplete [a]) +replicate m p = + let go n = + force $ + if n==0 + then return (Nothing, []) + else handleMsg + (\errMsg -> (Just errMsg, [])) + (appendIncomplete p (go (n-1))) + in go m + +{- | +The first parser may fail, but the second one must not. +-} +appendIncomplete :: + C parser => + parser (PossiblyIncomplete a) -> + parser (PossiblyIncomplete [a]) -> + parser (PossiblyIncomplete [a]) +appendIncomplete p ps = + do ~(me, x) <- p + liftM (mapSnd (x:)) $ force $ + maybe ps (\_ -> return (me,[])) me + +handleMsg :: + C parser => + (UserMessage -> a) -> parser a -> parser a +handleMsg handler action = + liftM + (either handler id) + (try action) diff --git a/src/Sound/MIDI/Parser/File.hs b/src/Sound/MIDI/Parser/File.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/File.hs @@ -0,0 +1,72 @@ +module Sound.MIDI.Parser.File + (T(..), runFile, runHandle, runIncompleteFile, + PossiblyIncomplete, UserMessage, ) where + +import qualified Sound.MIDI.Parser.Class as Parser +import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) + +import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), ask, liftM, lift, ) + +import qualified System.IO.Error as IOE +import qualified Control.Exception as Exc + +import qualified System.IO as IO +import qualified Sound.MIDI.IO as MIO +import Data.Char (ord) + +import qualified Numeric.NonNegative.Wrapper as NonNeg + + + +newtype T a = Cons {decons :: ReaderT IO.Handle IO a} + + +runFile :: T a -> FilePath -> IO a +runFile p name = + Exc.bracket + (IO.openBinaryFile name IO.ReadMode) + IO.hClose + (runHandle p) + +runHandle :: T a -> IO.Handle -> IO a +runHandle p h = + runReaderT (decons p) h + + + +{- | +Since in case of an incomplete file read, +we cannot know where the current file position is, +we omit the @runIncompleteHandle@ variant. +-} +runIncompleteFile :: T (PossiblyIncomplete a) -> FilePath -> IO a +runIncompleteFile p name = + Exc.bracket + (IO.openBinaryFile name IO.ReadMode) + IO.hClose + (\h -> + do (me,a) <- runHandle p h + maybe (return ()) + (\msg -> putStrLn $ "could not parse MIDI file completely: " ++ msg) me + return a) + + + +instance Monad T where + return = Cons . return + x >>= y = Cons $ decons . y =<< decons x + +fromIO :: (IO.Handle -> IO a) -> T a +fromIO act = Cons $ lift . act =<< ask + +instance Parser.C T where + isEnd = fromIO IO.hIsEOF + getByte = fromIO $ liftM (fromIntegral . ord) . IO.hGetChar + skip n = fromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n) + warn = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg)) + giveUp = Cons . lift . IOE.ioError . IOE.userError + try p = + Cons $ ReaderT $ \h -> + liftM (either (Left . show) Right) $ + IOE.try $ runReaderT (decons p) h + force p = p diff --git a/src/Sound/MIDI/Parser/Primitive.hs b/src/Sound/MIDI/Parser/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/Primitive.hs @@ -0,0 +1,109 @@ +{- | +Parse primitive types contained in MIDI files. +-} +module Sound.MIDI.Parser.Primitive + (getByte, + getN, getString, getBigN, getNByteInt, + get1, get2, get3, get4, + getNByteCardinal, + getVar, getVarBytes, + getEnum, makeEnum, ) where + +import qualified Sound.MIDI.Parser.Class as Parser +import qualified Control.Monad.State as State +import Control.Monad (replicateM, liftM, ) + +import Sound.MIDI.IO (ByteList, listCharFromByte, ) +import qualified Sound.MIDI.Bit as Bit +import Data.Bits (testBit, clearBit) +import Data.Word (Word8) +import qualified Numeric.NonNegative.Wrapper as NonNeg + + + +{- | +'getByte' gets a single byte from the input. +-} +getByte :: Parser.C parser => parser Word8 +getByte = Parser.getByte + + +{- | +@getN n@ returns n characters (bytes) from the input. +-} +getN :: Parser.C parser => NonNeg.Int -> parser ByteList +getN n = replicateM (NonNeg.toNumber n) getByte + +getString :: Parser.C parser => NonNeg.Integer -> parser String +getString n = liftM listCharFromByte (getBigN n) + +getBigN :: Parser.C parser => NonNeg.Integer -> parser ByteList +getBigN n = + sequence $ + Bit.replicateBig + (1 + fromIntegral (maxBound :: NonNeg.Int)) + (NonNeg.toNumber n) + getByte + + +{- | +'get1', 'get2', 'get3', and 'get4' take 1-, 2-, 3-, or +4-byte numbers from the input (respectively), convert the base-256 data +into a single number, and return. +-} +get1 :: Parser.C parser => parser Int +get1 = liftM fromIntegral getByte + +getNByteInt :: Parser.C parser => NonNeg.Int -> parser Int +getNByteInt n = + liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1) + +get2, get3, get4 :: Parser.C parser => parser Int +get2 = getNByteInt 2 +get3 = getNByteInt 3 +get4 = getNByteInt 4 + +getByteAsCardinal :: Parser.C parser => parser NonNeg.Integer +getByteAsCardinal = liftM fromIntegral getByte + +getNByteCardinal :: Parser.C parser => NonNeg.Int -> parser NonNeg.Integer +getNByteCardinal n = + liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) getByteAsCardinal) + +{- | +/Variable-length quantities/ are used often in MIDI notation. +They are represented in the following way: +Each byte (containing 8 bits) uses the 7 least significant bits to store information. +The most significant bit is used to signal whether or not more information is coming. +If it's @1@, another byte is coming. +If it's @0@, that byte is the last one. +'getVar' gets a variable-length quantity from the input. +-} +getVar :: Parser.C parser => parser NonNeg.Integer +getVar = + liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes + +{- | +The returned list contains only bytes with the most significant bit cleared. +These are digits of a 128-ary number. +-} +getVarBytes :: Parser.C parser => parser [Word8] +getVarBytes = + do + digit <- getByte + if flip testBit 7 digit -- if it's the last byte + then liftM (flip clearBit 7 digit :) getVarBytes + else return [digit] + + +getEnum :: (Parser.C parser, Enum enum, Bounded enum) => parser enum +getEnum = makeEnum =<< get1 + +makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> parser enum +makeEnum n = + let go :: (Parser.C parser, Enum a) => a -> a -> parser a + go lower upper = + if fromEnum lower <= n && n <= fromEnum upper + then return (toEnum n) + else Parser.giveUp ("value " ++ show n ++ " is out of range for enumeration") + in go minBound maxBound diff --git a/src/Sound/MIDI/Parser/Report.hs b/src/Sound/MIDI/Parser/Report.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/Report.hs @@ -0,0 +1,23 @@ +{- | +Definition of a datatype that reports on the success of a parser. +-} +module Sound.MIDI.Parser.Report where + + +{- | +This datatype is the result of a parser. +First it stores a sequence of warnings. +Warnings are for corruptions of the input which can be fixed. +After encountering a series of warnings, +there is finally an end, +either a successful one, with the result as @(Right result)@ +or an eventual non-fixable problem indicated by @(Left errorMessage)@. +-} +data T a = + Cons { + warnings :: [UserMessage], + result :: Either UserMessage a + } + deriving (Show, Eq) + +type UserMessage = String diff --git a/src/Sound/MIDI/Parser/Restricted.hs b/src/Sound/MIDI/Parser/Restricted.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/Restricted.hs @@ -0,0 +1,70 @@ +{- | +Parser which limits the input data to a given number of bytes. +We need this for parsing MIDI tracks and some MetaEvents, +where the length of a part is fixed by a length specification. +-} +module Sound.MIDI.Parser.Restricted + (T(..), run, ) where + +import qualified Sound.MIDI.Parser.Class as Parser + +import Control.Monad.State + (StateT(StateT, runStateT), mapStateT, + get, put, liftM, lift, when, ) + +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Prelude hiding (replicate, until, ) + + +run :: Parser.C parser => + NonNeg.Integer -> T parser a -> parser a +run maxLen p = + do (x,remaining) <- runStateT (decons p) maxLen + Parser.force $ when + (remaining>0) + (Parser.warn ("unparsed bytes left in part (" ++ show remaining ++ " bytes)")) + return x + + + +newtype T parser a = + Cons {decons :: StateT NonNeg.Integer parser a} + +instance Monad parser => Monad (T parser) where + return = Cons . return + x >>= y = Cons $ decons . y =<< decons x + +instance Parser.C parser => Parser.C (T parser) where + isEnd = + Cons $ get >>= \remaining -> + if remaining==0 then return True else lift Parser.isEnd + getByte = + Cons $ get >>= \remaining -> + do when (remaining==0) + (lift $ Parser.giveUp "unexpected end of part") +{- in principle not necessary, because Parser.getByte must check for remaining bytes + end <- lift Parser.isEnd + when end + (lift $ Parser.giveUp "part longer than container") +-} + put (remaining-1) + lift Parser.getByte + skip n = + Cons $ get >>= \remaining -> + if n>remaining + then lift $ Parser.giveUp "skip beyond end of part" + else put (remaining-n) >> lift (Parser.skip n) + warn = Cons . lift . Parser.warn + -- giveUp = Cons . lift . giveUp + giveUp errMsg = + Cons $ StateT $ \remain -> + Parser.skip remain >> Parser.giveUp errMsg + try (Cons st) = + Cons $ StateT $ \remain0 -> + liftM (either + (\errMsg -> (Left errMsg, 0)) + (\(x,remain1) -> (Right x, remain1))) $ + Parser.try (runStateT st remain0) + force (Cons st) = + Cons $ mapStateT Parser.force st diff --git a/src/Sound/MIDI/Parser/State.hs b/src/Sound/MIDI/Parser/State.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/State.hs @@ -0,0 +1,56 @@ +{- | +Very similar to "Sound.MIDI.Parser". +-} +module Sound.MIDI.Parser.State + (T, zeroOrMore, StateT(..), ) where + +import qualified Sound.MIDI.Parser.Class as Parser + +import Control.Monad.State (StateT(..), mapStateT, liftM, liftM2, lift, ) + + +type T st parser = StateT st parser + + +force :: Parser.C parser => + T st parser a -> T st parser a +force = mapStateT Parser.force + +zeroOrMore :: Parser.C parser => + T st parser a -> T st parser (Parser.PossiblyIncomplete [a]) +zeroOrMore p = + let go = + force $ isEnd >>= \b -> + if b + then return (Nothing, []) + else handleMsg + (\errMsg -> (Just errMsg, [])) + (liftM2 (\ x ~(e,xs) -> (e,x:xs)) p go) + in go + +{- +zeroOrMore :: T st [byte] a -> T st [byte] [a] +zeroOrMore p = + let go = + isEnd >>= \b -> + if b + then return [] + else liftM2 (:) p go + in go +-} + +{- | +In case of an exception, the handler restores the old state. +-} +handleMsg :: Parser.C parser => + (Parser.UserMessage -> a) -> T st parser a -> T st parser a +handleMsg handler action = + StateT $ \s -> + liftM + (either (\e -> (handler e, s)) id) + (Parser.try (runStateT action s)) + + +isEnd :: Parser.C parser => + T st parser Bool +isEnd = lift $ Parser.isEnd diff --git a/src/Sound/MIDI/Parser/Status.hs b/src/Sound/MIDI/Parser/Status.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/Status.hs @@ -0,0 +1,60 @@ +{- | +Parser which handles the running state +that is used in MIDI messages in realtime and files. +The running state consists of a message code and the message channel. +-} +module Sound.MIDI.Parser.Status + (T, Status, set, get, run, State.lift, + Channel, fromChannel, toChannel, ) where + +import qualified Sound.MIDI.Parser.State as ParserState + +import Control.Monad.State (evalStateT, ) +import qualified Control.Monad.State as State + +import Sound.MIDI.Utility (checkRange, ) +import Data.Ix (Ix) + + +{- | +The 'T' monad parses a track of a MIDI File. +In MIDI, a shortcut is used for long strings of similar MIDI events: +If a stream of consecutive events all have the same type and channel, +the type and channel can be omitted for all but the first event. +To implement this /feature/, +the parser must keep track of the type and channel of the most recent MIDI Event. +This is done by managing a 'Status' in the parser. +-} +type T parser a = ParserState.T Status parser a + +type Status = Maybe (Int,Channel) + + +set :: Monad parser => Status -> T parser () +set = State.put + +get :: Monad parser => T parser Status +get = State.get + +run :: Monad parser => T parser a -> parser a +run = flip evalStateT Nothing + + +-- * Channel definition + +{- | +This definition should be in Message.Channel, +but this results in a cyclic import. +-} +newtype Channel = Channel {fromChannel :: Int} deriving (Show, Eq, Ord, Ix) + +toChannel :: Int -> Channel +toChannel = checkRange "Channel" Channel + +instance Enum Channel where + toEnum = toChannel + fromEnum = fromChannel + +instance Bounded Channel where + minBound = Channel 0 + maxBound = Channel 15 diff --git a/src/Sound/MIDI/Parser/Stream.hs b/src/Sound/MIDI/Parser/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Parser/Stream.hs @@ -0,0 +1,176 @@ +module Sound.MIDI.Parser.Stream + (T(..), run, runIncomplete, runPartial, + ByteList(..), + PossiblyIncomplete, UserMessage, processReport, ) where + + +import Control.Monad.State + (State(runState), evalState, + get, put, liftM, when, ) + +import qualified Sound.MIDI.Parser.Report as Report +import qualified Sound.MIDI.Parser.Class as Parser +import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) + +import qualified Sound.MIDI.IO as MIO + +import Data.Word (Word8) +import qualified Data.List as List + +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Prelude hiding (replicate, until, drop, ) + + + +{- +Instead of using Report and write the monad instance manually, +we could also use WriterT monad for warnings and ErrorT monad for failure handling. +-} +newtype T str a = Cons {decons :: State str (Report.T a)} + + + +runPartial :: T str a -> str -> (Report.T a, str) +runPartial parser input = + flip runState input (decons parser) + +run :: ByteStream str => T str a -> str -> Report.T a +run parser input = + flip evalState input $ decons $ + (do a <- parser + end <- Parser.isEnd + Parser.force $ when (not end) (warn "unparsed data left over") + return a) + +{- | +Treat errors which caused an incomplete data structure as warnings. +This is reasonable, because we do not reveal the remaining unparsed data +and thus further parsing is not possible. +-} +runIncomplete :: ByteStream str => + T str (PossiblyIncomplete a) -> str -> Report.T a +runIncomplete parser input = + flip run input $ + do (me,x) <- parser + Parser.force $ maybe (return ()) warn me + return x + + + +fromState :: State str a -> T str a +fromState p = + Cons $ liftM (\a -> Report.Cons [] (Right a)) p + + +instance Monad (T str) where + return x = fromState $ return x + x >>= y = Cons $ + decons x >>= \ a -> + case Report.result a of + Left err -> return (Report.Cons (Report.warnings a) (Left err)) + Right ar -> + liftM (\b -> +-- b{Report.warnings = Report.warnings a ++ Report.warnings b} + -- more lazy + Report.Cons + (Report.warnings a ++ Report.warnings b) + (Report.result b) + ) $ + decons (y ar) + +class ByteStream str where + switchL :: a -> (Word8 -> str -> a) -> str -> a + drop :: NonNeg.Integer -> str -> str + +newtype ByteList = ByteList MIO.ByteList + +instance ByteStream ByteList where + switchL n j (ByteList xss) = + case xss of + (x:xs) -> j x (ByteList xs) + _ -> n + drop n (ByteList xs) = ByteList $ List.genericDrop n xs + +instance ByteStream str => Parser.C (T str) where + isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get + getByte = + switchL + (giveUp "unexpected end of data") + (\s ss -> fromState (put ss) >> return s) =<< + fromState get +{- + skip n = sequence_ (genericReplicate n Parser.getByte) +-} + skip n = when (n>0) $ + do s <- fromState get + switchL + (Parser.giveUp "skip past end of part") + (\ _ rest -> fromState $ put rest) + (drop (n-1) s) + warn = warn + giveUp = giveUp + try = try + force = force + + +warn :: String -> T str () +warn text = + Cons $ return $ Report.Cons [text] (Right ()) + +giveUp :: String -> T str a +giveUp text = + Cons $ return $ Report.Cons [] (Left text) + +try :: T str a -> T str (Either UserMessage a) +try = + -- more lazy + Cons . + liftM (\r -> Report.Cons (Report.warnings r) (Right (Report.result r))) . + -- liftM (\r -> r{Report.result = Right (Report.result r)}) . + decons + + +{- | +Wadler's force function + +'force' guarantees that the parser does not fail. +Thus it makes parsing more lazy. +However if the original parser fails though, +then we get an unrecoverable /irrefutable pattern/ error on 'Just'. +-} +force :: T str a -> T str a +force p = + Cons $ + do ~(Report.Cons w ~(Right x)) <- decons p + return (Report.Cons w (Right x)) + + +{- | +Emit all Report.warnings and throw the error from the report. +-} +processReport :: Report.T a -> T str a +processReport report = + mapM_ warn (Report.warnings report) >> + either giveUp return (Report.result report) + + +{- +laziness problems: +fst $ runPartial (Parser.try (undefined :: T ByteList String)) $ ByteList [] +fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.try (return "bla" :: T ByteList String))) $ ByteList [] +fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.handleMsg id undefined)) $ ByteList [] +evalState (sequence $ repeat $ return 'a') "" +fst $ runPartial (sequence $ repeat $ return 'a') "" + +fmap snd $ Report.result $ fst $ runPartial (Parser.appendIncomplete (return (undefined,'a')) (return (undefined,"bc"))) (ByteList $ repeat 129) +fmap snd $ Report.result $ fst $ runPartial ((return (undefined,'a'))) (ByteList $ repeat 129) +fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (Nothing,'a'))) (ByteList $ repeat 129) +fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (undefined,'a'))) (ByteList $ repeat 129) +fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) +either error snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) +Report.result $ run (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) +Report.result $ runIncomplete (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129) +Report.result $ runIncomplete (Parser.replicate 1000000 (liftM ((,) Nothing) Parser.getByte)) (ByteList $ repeat 129) +Report.result $ runIncomplete (Parser.until (128==) Parser.getByte) (ByteList $ repeat 129) +-} diff --git a/src/Sound/MIDI/ParserState.hs b/src/Sound/MIDI/ParserState.hs deleted file mode 100644 --- a/src/Sound/MIDI/ParserState.hs +++ /dev/null @@ -1,30 +0,0 @@ -{- | -Very similar to "Sound.MIDI.Parser". --} - -module Sound.MIDI.ParserState - (T, zeroOrMore, oneOrMore, StateT(..), ) where - -import qualified Sound.MIDI.Parser as Parser - -import Control.Monad.State (StateT(..), mapStateT, liftM2, mplus, ) - -type T st s = StateT st (Parser.T s) - - -{- | -Wadler's force function - -'force' guarantees that the parser does not fail. -Thus it makes parsing more lazy. -However if the original parser fails though, -then we get an unrecoverable /irrefutable pattern/ error on 'Just'. --} -force :: T st s a -> T st s a -force = mapStateT Parser.force - -zeroOrMore :: T st s a -> T st s [a] -zeroOrMore p = force $ oneOrMore p `mplus` return [] - -oneOrMore :: T st s a -> T st s [a] -oneOrMore p = liftM2 (:) p (zeroOrMore p) diff --git a/src/Sound/MIDI/Utility.hs b/src/Sound/MIDI/Utility.hs --- a/src/Sound/MIDI/Utility.hs +++ b/src/Sound/MIDI/Utility.hs @@ -1,6 +1,10 @@ module Sound.MIDI.Utility where +import qualified Test.QuickCheck as QC +import System.Random (Random(randomR), RandomGen) +import Data.Word(Word8) + {-# INLINE mapFst #-} mapFst :: (a -> c) -> (a,b) -> (c,b) mapFst f ~(x,y) = (f x, y) @@ -30,3 +34,104 @@ {-# INLINE swap #-} swap :: (a,b) -> (b,a) swap (a,b) = (b,a) + +{-# INLINE checkRange #-} +checkRange :: (Bounded a, Ord a, Show a) => + String -> (Int -> a) -> Int -> a +checkRange typ f x = + let y = f x + in if minBound <= y && y <= maxBound + then y + else error (typ ++ ": value " ++ show x ++ " outside range " ++ + show ((minBound, maxBound) `asTypeOf` (y,y))) + +{-# INLINE viewR #-} +viewR :: [a] -> Maybe ([a], a) +viewR = + foldr (\x mxs -> Just (maybe ([],x) (mapFst (x:)) mxs)) Nothing + +{-# INLINE dropMatch #-} +dropMatch :: [b] -> [a] -> [a] +dropMatch xs ys = + snd $ head $ + dropWhile (not . null . fst) $ + zip (iterate (drop 1) xs) (iterate (drop 1) ys) + +{-# INLINE untilM #-} +untilM :: Monad m => (a -> Bool) -> m a -> m a +untilM p act = + let go = + act >>= \x -> + if p x + then return x + else go + in go + +{-# INLINE loopM #-} +loopM :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m a +loopM p preExit postExit = + let go = + preExit >>= \x -> + if p x + then return x + else postExit x >> go + in go + + + + +-- random generators + +enumRandomR :: (Enum a, RandomGen g) => (a,a) -> g -> (a,g) +enumRandomR (l,r) = + mapFst toEnum . randomR (fromEnum l, fromEnum r) + +boundedEnumRandom :: (Enum a, Bounded a, RandomGen g) => g -> (a,g) +boundedEnumRandom = enumRandomR (minBound, maxBound) + +chooseEnum :: (Enum a, Bounded a, Random a) => QC.Gen a +chooseEnum = QC.choose (minBound, maxBound) + + +quantityRandomR :: (Random b, RandomGen g) => + (a -> b) -> (b -> a) -> (a,a) -> g -> (a,g) +quantityRandomR fromQuantity toQuantity (l,r) = + mapFst toQuantity . randomR (fromQuantity l, fromQuantity r) + +boundedQuantityRandom :: (Bounded a, Random b, RandomGen g) => + (a -> b) -> (b -> a) -> g -> (a,g) +boundedQuantityRandom fromQuantity toQuantity = + quantityRandomR fromQuantity toQuantity (minBound, maxBound) + +chooseQuantity :: (Bounded a, Random b) => + (a -> b) -> (b -> a) -> QC.Gen a +chooseQuantity fromQuantity toQuantity = + fmap toQuantity $ QC.choose (fromQuantity minBound, fromQuantity maxBound) + + +newtype ArbChar = ArbChar {deconsArbChar :: Char} + +instance QC.Arbitrary ArbChar where + arbitrary = + fmap ArbChar $ + QC.frequency + [(26, QC.choose ('a','z')), + (26, QC.choose ('A','Z')), + (10, QC.choose ('0','9'))] + coarbitrary = error "not implemented" + +arbitraryString :: QC.Gen String +arbitraryString = + fmap (map deconsArbChar) QC.arbitrary + + +newtype ArbByte = ArbByte {deconsArbByte :: Word8} + +instance QC.Arbitrary ArbByte where + arbitrary = + fmap (ArbByte . fromIntegral) $ QC.choose (0,0xFF::Int) + coarbitrary = error "not implemented" + +arbitraryByteList :: QC.Gen [Word8] -- ByteList +arbitraryByteList = + fmap (map deconsArbByte) QC.arbitrary diff --git a/src/Sound/MIDI/Writer/Basic.hs b/src/Sound/MIDI/Writer/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Writer/Basic.hs @@ -0,0 +1,157 @@ +module Sound.MIDI.Writer.Basic where + +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import qualified Sound.MIDI.Bit as Bit +import Data.Bits ((.|.)) +import qualified Sound.MIDI.IO as MIO +import Sound.MIDI.IO (listByteFromChar, ) +import Control.Monad.Writer (Writer, execWriter, tell, ) +import Control.Monad.Reader (ReaderT, runReaderT, ask, lift, ) +import Data.List (genericLength, ) +import Data.Word (Word8) +import Data.Char (chr) + +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as Binary +import Data.Binary.Put (PutM, runPut, putLazyByteString, ) + +import Control.Exception (bracket, ) +import qualified System.IO as IO +import System.IO (openBinaryFile, hClose, hPutChar, Handle, IOMode(WriteMode)) +-- import System.IO.Error (ioError, userError) + +import Prelude hiding (putStr, ) + + + +class Monad m => C m where + putByte :: Word8 -> m () + {- | + @putLengthBlock n writeBody@ + write @n@ bytes indicating the number of bytes written by @writeBody@ + and then it runs @writeBody@. + -} + putLengthBlock :: Int -> m () -> m () + + +newtype ByteList a = + ByteList {unByteList :: Writer MIO.ByteList a} + +instance Monad ByteList where + return = ByteList . return + x >>= y = ByteList $ unByteList . y =<< unByteList x + +instance C ByteList where + putByte = ByteList . tell . (:[]) + putLengthBlock n writeBody = + let body = runByteList writeBody + in putInt n (length body) >> putByteList body + + +runByteList :: ByteList () -> MIO.ByteList +runByteList = execWriter . unByteList + + + + +newtype ByteString a = + ByteString {unByteString :: PutM a} + +instance Monad ByteString where + return = ByteString . return + x >>= y = ByteString $ unByteString . y =<< unByteString x + +instance C ByteString where + putByte = ByteString . Binary.putWord8 + putLengthBlock n writeBody = + let body = runByteString writeBody + len = B.length body + errLen = + if len >= div (256^n) 2 + then error "Chunk too large" + else fromIntegral len + in putInt n errLen >> ByteString (putLazyByteString body) + + +runByteString :: ByteString () -> B.ByteString +runByteString = runPut . unByteString + + + + +newtype SeekableFile a = + SeekableFile {unSeekableFile :: ReaderT Handle IO a} + +instance Monad SeekableFile where + return = SeekableFile . return + x >>= y = SeekableFile $ unSeekableFile . y =<< unSeekableFile x + +instance C SeekableFile where + putByte c = + SeekableFile $ + ask >>= \h -> + lift $ hPutChar h (chr $ fromIntegral c) + putLengthBlock n writeBody = + SeekableFile $ + ask >>= \h -> lift $ + do lenPos <- IO.hGetPosn h + IO.hPutStr h (replicate n '\000') + startPos <- IO.hTell h + runSeekableHandle h writeBody + stopPos <- IO.hTell h + contPos <- IO.hGetPosn h + IO.hSetPosn lenPos + let len = stopPos - startPos + if len >= 2^(31::Int) + then ioError (userError ("chunk too large, size " ++ show len)) + else runSeekableHandle h (putInt n (fromInteger len)) + IO.hSetPosn contPos + + +runSeekableFile :: FilePath -> SeekableFile () -> IO () +runSeekableFile name w = + bracket + (openBinaryFile name WriteMode) + hClose + (flip runSeekableHandle w) + +runSeekableHandle :: Handle -> SeekableFile () -> IO () +runSeekableHandle h w = + runReaderT (unSeekableFile w) h + + + + +putInt :: C writer => Int -> Int -> writer () +putInt a = putByteList . map fromIntegral . Bit.someBytes a + +putStr :: C writer => String -> writer () +putStr = putByteList . listByteFromChar + +putIntAsByte :: C writer => Int -> writer () +putIntAsByte x = putByte $ fromIntegral x + +putByteList :: C writer => MIO.ByteList -> writer () +putByteList = mapM_ putByte + +putLenByteList :: C writer => MIO.ByteList -> writer () +putLenByteList bytes = + do putVar (genericLength bytes) + putByteList bytes + +{- | +Numbers of variable size are represented by sequences of 7-bit blocks +tagged (in the top bit) with a bit indicating: +(1) that more data follows; or +(0) that this is the last block. +-} + +putVar :: C writer => NonNeg.Integer -> writer () +putVar n = + let bytes = map fromIntegral $ Bit.toBase 128 n + in case bytes of + [] -> putInt 1 0 + (_:bs) -> + let highBits = map (const 128) bs ++ [0] + in putByteList (zipWith (.|.) highBits bytes) diff --git a/src/Sound/MIDI/Writer/Status.hs b/src/Sound/MIDI/Writer/Status.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Writer/Status.hs @@ -0,0 +1,57 @@ +module Sound.MIDI.Writer.Status where + +-- import qualified Sound.MIDI.Writer.Basic as Writer + +import Sound.MIDI.Parser.Status (Channel) + +import Control.Monad.State (StateT, evalStateT, get, put, ) +import Control.Monad.Reader (ReaderT, runReaderT, ask, ) +import Control.Monad.Trans (MonadTrans, lift, ) + + +type Status = Maybe (Int,Channel) + +{- | +The ReaderT Bool handles +whether running status should be respected (True) or ignored (False). +-} +newtype T writer a = + Cons {decons :: ReaderT Bool (StateT (Maybe Status) writer) a} + + +instance Monad writer => Monad (T writer) where + return = Cons . return + x >>= y = Cons $ decons . y =<< decons x + +-- | returns 'True' if status must be submitted (e.g. because it was changed) +change :: (Monad writer) => Status -> T writer Bool +change x = Cons $ + do b <- ask + if not b + then return True + else + lift $ + let mx = Just x + in do my <- get + put mx + return (mx/=my) + +clear :: (Monad writer) => T writer () +clear = Cons $ lift $ put Nothing + + +instance MonadTrans T where + lift = fromWriter + +fromWriter :: (Monad writer) => writer a -> T writer a +fromWriter = Cons . lift . lift + +toWriter :: (Monad writer) => Bool -> T writer a -> writer a +toWriter withStatus w = + evalStateT (runReaderT (decons w) withStatus) Nothing + +toWriterWithStatus :: (Monad writer) => T writer a -> writer a +toWriterWithStatus = toWriter True + +toWriterWithoutStatus :: (Monad writer) => T writer a -> writer a +toWriterWithoutStatus = toWriter False diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,243 @@ +{- +ToDo: + +check whether load of randomly corrupted files yields Parser errors rather than 'undefined'. + +Check parsing and serialization of MIDI messages. +-} +module Main where + +import qualified Sound.MIDI.File as MidiFile +import qualified Sound.MIDI.File.Load as Load +import qualified Sound.MIDI.File.Save as Save + +import qualified Sound.MIDI.File.Event.Meta as MetaEvent +import qualified Sound.MIDI.File.Event as Event + +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Sound.MIDI.Parser.Report as Report +import qualified Sound.MIDI.Parser.Class as Parser +import qualified Sound.MIDI.Parser.Stream as StreamParser + +import qualified Data.EventList.Relative.TimeBody as EventList +import Data.EventList.Relative.MixedBody ((/.), (./), ) + +import qualified Data.ByteString.Lazy as B +import qualified Data.List as List + +import Sound.MIDI.Utility (viewR, dropMatch, ) +import Control.Monad (when, ) + +import System.Random (mkStdGen, randomR, ) + +import qualified Numeric.NonNegative.Wrapper as NonNeg + +import Test.QuickCheck (quickCheck, ) + +-- import Debug.Trace (trace) + + + +testMidiName :: FilePath +testMidiName = "quickcheck-test.mid" + +exampleEmpty :: MidiFile.T +exampleEmpty = + MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) + [EventList.empty] + +exampleMeta :: MidiFile.T +exampleMeta = + MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) + [EventList.cons 0 (Event.MetaEvent (MetaEvent.Lyric "foobarz")) EventList.empty] + +exampleStatus :: MidiFile.T +exampleStatus = + let chan = ChannelMsg.toChannel 3 + vel = VoiceMsg.toVelocity 64 + in MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10) + [0 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 20) vel))) ./ + 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 24) vel))) ./ + 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 27) vel))) ./ + 7 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 20) vel))) ./ + 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 24) vel))) ./ + 4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 27) vel))) ./ + EventList.empty] + +runExample :: MidiFile.T -> IO () +runExample example = + let bin = Save.toByteString example + struct = Load.maybeFromByteString bin + report = Report.Cons [] (Right example) + in B.writeFile testMidiName bin >> + print (struct == report) >> + when (struct/=report) + (print struct >> print report) + +-- provoke a test failure in order to see some examples of Arbitrary MIDI files +checkArbitrary :: MidiFile.T -> Bool +checkArbitrary (MidiFile.Cons _typ _division tracks) = + length (EventList.toPairList (EventList.concat tracks)) < 10 + + +saveLoadByteString :: MidiFile.T -> Bool +saveLoadByteString midi = + let bin = Save.toByteString midi + struct = Load.maybeFromByteString bin + report = Report.Cons [] (Right midi) + in struct == report + +saveLoadCompressedByteString :: MidiFile.T -> Bool +saveLoadCompressedByteString midi = + let bin = Save.toCompressedByteString midi + struct = Load.maybeFromByteString bin + report = Report.Cons [] (Right (MidiFile.implicitNoteOff midi)) + in struct == report + +saveLoadMaybeByteList :: MidiFile.T -> Bool +saveLoadMaybeByteList midi = + let bin = Save.toByteList midi + struct = Load.maybeFromByteList bin + report = Report.Cons [] (Right midi) + in struct == report + +saveLoadByteList :: MidiFile.T -> Bool +saveLoadByteList midi = + midi == Load.fromByteList (Save.toByteList midi) + + +saveLoadFile :: MidiFile.T -> IO Bool +saveLoadFile midi = + do Save.toSeekableFile testMidiName midi + struct <- Load.fromFile testMidiName + return $ struct == midi + + +loadSaveByteString :: MidiFile.T -> Bool +loadSaveByteString midi0 = + let bin0 = Save.toByteString midi0 + in case Load.maybeFromByteString bin0 of + Report.Cons [] (Right midi1) -> + bin0 == Save.toByteString midi1 + _ -> False + +loadSaveCompressedByteString :: MidiFile.T -> Bool +loadSaveCompressedByteString midi0 = + let bin0 = Save.toCompressedByteString midi0 + in case Load.maybeFromByteString bin0 of + Report.Cons [] (Right midi1) -> + bin0 == Save.toByteString midi1 + _ -> False + +loadSaveByteList :: MidiFile.T -> Bool +loadSaveByteList midi0 = + let bin0 = Save.toByteList midi0 + in case Load.maybeFromByteList bin0 of + Report.Cons [] (Right midi1) -> + bin0 == Save.toByteList midi1 + _ -> False + + +restrictionByteList :: MidiFile.T -> Bool +restrictionByteList midi = + let bin = Save.toByteList midi + in Load.fromByteList bin == + Load.fromByteList (bin++[undefined]) + + +lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool +lazinessZeroOrMoreByteList pos byte = + let result = + Report.result $ StreamParser.runIncomplete (Parser.zeroOrMore Parser.getByte) $ + StreamParser.ByteList $ repeat $ fromIntegral byte + char = show result !! mod (NonNeg.toNumber pos) 1000 + in char == char + +lazinessByteList :: MidiFile.T -> Bool +lazinessByteList (MidiFile.Cons typ divsn tracks00) = + let tracks0 = filter (not . EventList.null) tracks00 + bin0 = Save.toByteList (MidiFile.Cons typ divsn tracks0) + {- remove trailing EndOfTrack and its time stamp and replace the last by + bin1 = take (length bin0 - 5) bin0 ++ [undefined] + -} + bin1 = init bin0 ++ [undefined] + (MidiFile.Cons _ _ tracks1) = Load.fromByteList bin1 + in case viewR tracks0 of + Just (initTracks0, lastTrack0) -> + List.isPrefixOf initTracks0 tracks1 && + let (lastTrack1:_) = dropMatch initTracks0 tracks1 + in List.isPrefixOf + (init (EventList.toPairList lastTrack0)) + (EventList.toPairList lastTrack1) +{- + fmap fst (EventList.viewR lastTrack0) == + fmap fst (EventList.viewR lastTrack1) +-} + _ -> True + + +{- | +Check whether corruptions in a file are properly detected +and do not trap into an errors. +-} +corruptionByteString :: Int -> Int -> MidiFile.T -> Bool +corruptionByteString seed replacement midi = + let bin = Save.toByteString midi + n = fst $ randomR (0, fromIntegral $ B.length bin :: Int) (mkStdGen seed) + (pre, post) = B.splitAt (fromIntegral n) bin + replaceByte = fromIntegral replacement + corruptBin = + B.append pre + (if B.null post + then B.singleton replaceByte + else B.cons replaceByte (B.tail post)) + in -- trace (show (B.unpack corruptBin)) $ + case Load.maybeFromByteString corruptBin of + Report.Cons _ _ -> True + +corruptionByteList :: Int -> Int -> MidiFile.T -> Bool +corruptionByteList seed replacement midi = + let bin = Save.toByteList midi + n = fst $ randomR (0, length bin) (mkStdGen seed) + (pre, post) = splitAt n bin + corruptBin = + pre ++ fromIntegral replacement : + if null post then [] else tail post + in case Load.maybeFromByteList corruptBin of + Report.Cons _ _ -> True + + +main :: IO () +main = + do runExample exampleEmpty + runExample exampleMeta + runExample exampleStatus + saveLoadFile exampleStatus >>= print + quickCheck saveLoadByteString + quickCheck saveLoadCompressedByteString + quickCheck saveLoadMaybeByteList + quickCheck saveLoadByteList +-- quickCheck saveLoadFile + quickCheck loadSaveByteString + quickCheck loadSaveCompressedByteString + quickCheck loadSaveByteList + + quickCheck restrictionByteList + + quickCheck lazinessZeroOrMoreByteList + quickCheck lazinessByteList + + quickCheck corruptionByteList + quickCheck corruptionByteString + +{- +laziness test: +The following expressions should return the prefix of the track before running into "undefined". +I don't know, how to formalize that. + +Load.fromByteList [77,84,104,100,0,0,0,6,0,1,0,1,0,10,77,84,114,107,0,0,0,28,0,147,20,64,4,147,24,64,4,147,27,64,7,131,20,64,4,131,24,64,4,131,27,64,0,255,47,undefined] + +Report.result $ StreamParser.runIncomplete Load.getTrackChunk $ StreamParser.ByteList [77,84,114,107,0,0,0,28,0,147,20,64,4,147,24,64,4,147,27,64,7,131,20,64,4,131,24,64,4,131,27,64,0,255,47,undefined] +-}