midi 0.0.7 → 0.1.1
raw patch · 34 files changed
+3629/−1322 lines, 34 filesdep +binarydep +bytestringnew-component:exe:test
Dependencies added: binary, bytestring
Files
- midi.cabal +46/−8
- src/Sound/MIDI/Event.hs +0/−552
- src/Sound/MIDI/File.hs +107/−113
- src/Sound/MIDI/File/Event.hs +118/−0
- src/Sound/MIDI/File/Event/Meta.hs +258/−0
- src/Sound/MIDI/File/Event/SystemExclusive.hs +44/−0
- src/Sound/MIDI/File/Load.hs +155/−353
- src/Sound/MIDI/File/Save.hs +73/−183
- src/Sound/MIDI/General.hs +27/−40
- src/Sound/MIDI/IO.hs +11/−11
- src/Sound/MIDI/Manufacturer.hs +366/−0
- src/Sound/MIDI/Message.hs +85/−0
- src/Sound/MIDI/Message/Channel.hs +125/−0
- src/Sound/MIDI/Message/Channel/Mode.hs +107/−0
- src/Sound/MIDI/Message/Channel/Voice.hs +441/−0
- src/Sound/MIDI/Message/System.hs +59/−0
- src/Sound/MIDI/Message/System/Common.hs +71/−0
- src/Sound/MIDI/Message/System/Exclusive.hs +76/−0
- src/Sound/MIDI/Message/System/RealTime.hs +47/−0
- src/Sound/MIDI/Parser.hs +0/−32
- src/Sound/MIDI/Parser/ByteString.hs +129/−0
- src/Sound/MIDI/Parser/Class.hs +156/−0
- src/Sound/MIDI/Parser/File.hs +72/−0
- src/Sound/MIDI/Parser/Primitive.hs +109/−0
- src/Sound/MIDI/Parser/Report.hs +23/−0
- src/Sound/MIDI/Parser/Restricted.hs +70/−0
- src/Sound/MIDI/Parser/State.hs +56/−0
- src/Sound/MIDI/Parser/Status.hs +60/−0
- src/Sound/MIDI/Parser/Stream.hs +176/−0
- src/Sound/MIDI/ParserState.hs +0/−30
- src/Sound/MIDI/Utility.hs +105/−0
- src/Sound/MIDI/Writer/Basic.hs +157/−0
- src/Sound/MIDI/Writer/Status.hs +57/−0
- test/Main.hs +243/−0
midi.cabal view
@@ -1,5 +1,5 @@ Name: midi-Version: 0.0.7+Version: 0.1.1 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -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
− src/Sound/MIDI/Event.hs
@@ -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 -}
src/Sound/MIDI/File.hs view
@@ -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))
+ src/Sound/MIDI/File/Event.hs view
@@ -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)
+ src/Sound/MIDI/File/Event/Meta.hs view
@@ -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
+ src/Sound/MIDI/File/Event/SystemExclusive.hs view
@@ -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
src/Sound/MIDI/File/Load.hs view
@@ -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)
src/Sound/MIDI/File/Save.hs view
@@ -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.")
src/Sound/MIDI/General.hs view
@@ -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)
src/Sound/MIDI/IO.hs view
@@ -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)
+ src/Sound/MIDI/Manufacturer.hs view
@@ -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
+ src/Sound/MIDI/Message.hs view
@@ -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
+ src/Sound/MIDI/Message/Channel.hs view
@@ -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)
+ src/Sound/MIDI/Message/Channel/Mode.hs view
@@ -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
+ src/Sound/MIDI/Message/Channel/Voice.hs view
@@ -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!!
+ src/Sound/MIDI/Message/System.hs view
@@ -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
+ src/Sound/MIDI/Message/System/Common.hs view
@@ -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
+ src/Sound/MIDI/Message/System/Exclusive.hs view
@@ -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
+ src/Sound/MIDI/Message/System/RealTime.hs view
@@ -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
− src/Sound/MIDI/Parser.hs
@@ -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)
+ src/Sound/MIDI/Parser/ByteString.hs view
@@ -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))
+ src/Sound/MIDI/Parser/Class.hs view
@@ -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)
+ src/Sound/MIDI/Parser/File.hs view
@@ -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
+ src/Sound/MIDI/Parser/Primitive.hs view
@@ -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
+ src/Sound/MIDI/Parser/Report.hs view
@@ -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
+ src/Sound/MIDI/Parser/Restricted.hs view
@@ -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
+ src/Sound/MIDI/Parser/State.hs view
@@ -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
+ src/Sound/MIDI/Parser/Status.hs view
@@ -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
+ src/Sound/MIDI/Parser/Stream.hs view
@@ -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)+-}
− src/Sound/MIDI/ParserState.hs
@@ -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)
src/Sound/MIDI/Utility.hs view
@@ -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
+ src/Sound/MIDI/Writer/Basic.hs view
@@ -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)
+ src/Sound/MIDI/Writer/Status.hs view
@@ -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
+ test/Main.hs view
@@ -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]+-}