midi 0.1.7.1 → 0.2.2.6
raw patch · 49 files changed
Files
- midi.cabal +49/−38
- parser/Sound/MIDI/Parser/Class.hs +174/−0
- parser/Sound/MIDI/Parser/Exception.hs +23/−0
- parser/Sound/MIDI/Parser/Stream.hs +137/−0
- parser/Sound/MIDI/Parser/Warning.hs +28/−0
- src/Sound/MIDI/Bit.hs +3/−2
- src/Sound/MIDI/ControllerPrivate.hs +0/−1
- src/Sound/MIDI/Example/ControllerRamp.hs +0/−6
- src/Sound/MIDI/Example/Tomatosalad.hs +0/−6
- src/Sound/MIDI/File.hs +16/−9
- src/Sound/MIDI/File/Event.hs +7/−5
- src/Sound/MIDI/File/Event/Meta.hs +19/−77
- src/Sound/MIDI/File/Event/SystemExclusive.hs +1/−1
- src/Sound/MIDI/File/Load.hs +11/−14
- src/Sound/MIDI/File/Save.hs +13/−10
- src/Sound/MIDI/General.hs +3/−2
- src/Sound/MIDI/IO.hs +1/−0
- src/Sound/MIDI/KeySignature.hs +182/−0
- src/Sound/MIDI/MachineControl.hs +198/−0
- src/Sound/MIDI/Manufacturer.hs +1/−1
- src/Sound/MIDI/Message.hs +8/−4
- src/Sound/MIDI/Message/Channel.hs +18/−10
- src/Sound/MIDI/Message/Channel/Mode.hs +2/−2
- src/Sound/MIDI/Message/Channel/Voice.hs +29/−25
- src/Sound/MIDI/Message/Class/Check.hs +85/−39
- src/Sound/MIDI/Message/Class/Construct.hs +111/−0
- src/Sound/MIDI/Message/Class/Query.hs +120/−0
- src/Sound/MIDI/Message/Class/Utility.hs +57/−0
- src/Sound/MIDI/Message/System.hs +2/−3
- src/Sound/MIDI/Message/System/Common.hs +1/−1
- src/Sound/MIDI/Message/System/Exclusive.hs +4/−4
- src/Sound/MIDI/Message/System/RealTime.hs +1/−2
- src/Sound/MIDI/Monoid.hs +11/−8
- src/Sound/MIDI/Parser/ByteString.hs +11/−7
- src/Sound/MIDI/Parser/Class.hs +0/−174
- src/Sound/MIDI/Parser/Exception.hs +0/−24
- src/Sound/MIDI/Parser/File.hs +20/−10
- src/Sound/MIDI/Parser/Primitive.hs +14/−14
- src/Sound/MIDI/Parser/Restricted.hs +15/−8
- src/Sound/MIDI/Parser/Status.hs +14/−6
- src/Sound/MIDI/Parser/Stream.hs +0/−130
- src/Sound/MIDI/Parser/Warning.hs +0/−28
- src/Sound/MIDI/Utility.hs +2/−53
- src/Sound/MIDI/Writer/Basic.hs +21/−16
- src/Sound/MIDI/Writer/Status.hs +46/−34
- test/Common.hs +6/−0
- test/Example.hs +45/−0
- test/Main.hs +134/−82
- test/Parser.hs +19/−0
midi.cabal view
@@ -1,14 +1,14 @@ Name: midi-Version: 0.1.7.1+Version: 0.2.2.6 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de> Maintainer: Henning Thielemann <haskell@henning-thielemann.de>-Homepage: http://www.haskell.org/haskellwiki/MIDI+Homepage: http://wiki.haskell.org/MIDI Category: Sound, Music-Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3-Tested-With: GHC==7.0.4, GHC==7.2.1-Cabal-Version: >=1.6+Tested-With: GHC==7.0.4, GHC==7.2.2, GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1+Tested-With: GHC==8.4.1+Cabal-Version: 1.14 Build-Type: Simple Synopsis: Handling of MIDI messages and files Description:@@ -25,40 +25,31 @@ src/Sound/MIDI/Example/Tomatosalad.hs Source-Repository head type: darcs- location: http://code.haskell.org/~thielema/midi/+ location: https://hub.darcs.net/thielema/midi/ Source-Repository this type: darcs- location: http://code.haskell.org/~thielema/midi/- tag: 0.1.7.1--Flag splitBase- description: Choose the new smaller, split-up base package.--Flag buildTests- description: Build test executables- default: False+ location: https://hub.darcs.net/thielema/midi/+ tag: 0.2.2.6 Library Build-Depends:- event-list >=0.0.9 && < 0.2,- non-negative>=0.0.1 && <0.2,- explicit-exception >=0.1 && <0.2,- bytestring >=0.9.0.1 && <0.10,- binary >=0.4.2 && <0.6,- transformers >=0.2 && <0.3,- monoid-transformer >=0.0.1 && <0.1,- QuickCheck >=1 && <3- If flag(splitBase)- Build-Depends:- random >=1 && <2,- base >= 3 && <5- Else- Build-Depends:- base >= 1.0 && < 3+ event-list >=0.0.9 && <0.2,+ non-negative >=0.0.1 && <0.2,+ semigroups >=0.1 && <1,+ utility-ht >=0.0.10 && <0.1,+ explicit-exception >=0.1 && <0.3,+ bytestring >=0.9.0.1 && <0.13,+ binary >=0.4.2 && <0.11,+ transformers >=0.2 && <0.7,+ monoid-transformer >=0.0.4 && <0.1,+ QuickCheck >=2.1 && <3,+ random >=1 && <2,+ base >=4.11 && <5 + Default-Language: Haskell2010 GHC-Options: -Wall- Hs-Source-Dirs: src+ Hs-Source-Dirs: src, parser Exposed-Modules: Sound.MIDI.File Sound.MIDI.File.Event@@ -76,8 +67,12 @@ Sound.MIDI.Message.System.Common Sound.MIDI.Message.System.RealTime Sound.MIDI.Message.Class.Check+ Sound.MIDI.Message.Class.Query+ Sound.MIDI.Message.Class.Construct+ Sound.MIDI.MachineControl Sound.MIDI.Controller Sound.MIDI.Manufacturer+ Sound.MIDI.KeySignature Sound.MIDI.General -- exports ByteList data type Sound.MIDI.IO@@ -101,17 +96,33 @@ Sound.MIDI.Monoid Sound.MIDI.String Sound.MIDI.Utility+ Sound.MIDI.Message.Class.Utility -- type definition Sound.MIDI.ControllerPrivate -- didactic example Sound.MIDI.Example.ControllerRamp -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+Test-Suite test+ Type: exitcode-stdio-1.0+ Build-Depends:+ midi,+ explicit-exception,+ event-list,+ non-negative,+ utility-ht,+ QuickCheck,+ transformers,+ bytestring,+ base+ Hs-source-dirs: test, parser GHC-Options: -Wall+ Default-Language: Haskell2010 Main-Is: Main.hs+ Other-Modules:+ Example+ Parser+ Common+ Sound.MIDI.Parser.Class+ Sound.MIDI.Parser.Exception+ Sound.MIDI.Parser.Stream+ Sound.MIDI.Parser.Warning
+ parser/Sound/MIDI/Parser/Class.hs view
@@ -0,0 +1,174 @@+module Sound.MIDI.Parser.Class+ (EndCheck, isEnd,+ C, getByte, skip,+ warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,+ until, zeroOrMore, zeroOrMoreInc, replicate,+ emptyList, PossiblyIncomplete, UserMessage,+ Fragile, Partial,+ {- for debugging+ absorbException, appendIncomplete,+ -}+ ) where+++import Sound.MIDI.Parser.Report (UserMessage)+import qualified Sound.MIDI.Parser.Exception as Exc+import qualified Control.Monad.Exception.Asynchronous as Async+import qualified Control.Monad.Exception.Synchronous as Sync++import Control.Monad.Trans.Class (lift, )+import Control.Monad.Trans.State (StateT, )+import Control.Monad (liftM, liftM2, when, )++import Data.Word (Word8)++import qualified Numeric.NonNegative.Wrapper as NonNeg++import Prelude hiding (replicate, until, )++++class Monad parser => EndCheck parser where+ isEnd :: parser Bool++-- would be probably better placed in Parser.Status+instance EndCheck parser => EndCheck (StateT st parser) where+ isEnd = lift $ isEnd+++class EndCheck parser => C parser where+ getByte :: Fragile parser Word8+ skip :: NonNeg.Integer -> Fragile parser ()+ warn :: UserMessage -> parser ()+++{- |+@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.+-}+type PossiblyIncomplete a = Async.Exceptional UserMessage a+++type Fragile parser = Sync.ExceptionalT UserMessage parser+type Partial parser a = parser (PossiblyIncomplete a)+++warnIf :: C parser => Bool -> UserMessage -> parser ()+warnIf b msg = when b (warn msg)++{- |+Emit a warning if a value is said to be incomplete.+Be careful using this function,+because an incomplete value often means+that subsequent parse actions will process data from the wrong position.+Only use this function if you+either know that the parse is complete also if the parsed value is incomplete+or if there are no subsequent parse actions to run.++This function cannot fail.+-}+warnIncomplete :: C parser => PossiblyIncomplete a -> parser a+warnIncomplete ~(Async.Exceptional me a) =+ do maybe (return ()) warn me+ return a+++{- |+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 :: EndCheck parser =>+ Fragile parser a -> Partial parser [a]+zeroOrMore p =+ let go =+ isEnd >>= \b ->+ if b+ then return emptyList+ else absorbException+ (liftM2 (\ x -> fmap (x:)) p (lift go))+ in go+++zeroOrMoreInc :: EndCheck parser =>+ Partial (Fragile parser) a -> Partial parser [a]+zeroOrMoreInc p =+ let go =+ isEnd >>= \b ->+ if b+ then return emptyList+ else absorbException+ (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 signaled.+-}+until :: EndCheck parser =>+ (a -> Bool) -> Fragile parser a -> Partial parser [a]+until c p =+ let go =+ isEnd >>= \b ->+ if b+ then+ return $ Async.broken+ "Parser.until: unexpected end of input" []+ else+ absorbException $+ p >>= \x ->+ if c x+ then return emptyList+ else liftM (fmap (x:)) (lift go)+ in go+++{- |+This function will never fail.+It may however return a list that is shorter than requested.+-}+replicate ::+ C parser =>+ NonNeg.Int ->+ Partial (Fragile parser) a ->+ Partial parser [a]+replicate m p =+ let go n =+ if n==0+ then return emptyList+ else absorbException+ (appendIncomplete p (go (n-1)))+ in go m+++emptyList :: PossiblyIncomplete [a]+emptyList = Async.pure []++{- |+The first parser may fail, but the second one must not.+-}+appendIncomplete ::+ Monad parser =>+ Partial (Fragile parser) a ->+ Partial parser [a] ->+ Partial (Fragile parser) [a]+appendIncomplete p ps =+ do ~(Async.Exceptional me x) <- p+ lift $ liftM (fmap (x:)) $+ maybe ps (\_ -> return (Async.Exceptional me [])) me++absorbException ::+ Monad parser =>+ Partial (Fragile parser) [a] ->+ Partial parser [a]+absorbException =+ Sync.resolveT (\errMsg -> return $ Async.broken errMsg [])
+ parser/Sound/MIDI/Parser/Exception.hs view
@@ -0,0 +1,23 @@+{- |+Handling of exceptions.+-}+module Sound.MIDI.Parser.Exception where++import qualified Sound.MIDI.Parser.Report as Report++import qualified Control.Monad.Exception.Synchronous as Sync+++type T m = Sync.ExceptionalT Report.UserMessage m+++run :: Monad m =>+ T m a -> m (Sync.Exceptional Report.UserMessage a)+run = Sync.runExceptionalT+++giveUp :: Monad m => String -> T m a+giveUp = Sync.throwT++try :: Monad m => T m a -> m (Sync.Exceptional Report.UserMessage a)+try = Sync.tryT
+ parser/Sound/MIDI/Parser/Stream.hs view
@@ -0,0 +1,137 @@+module Sound.MIDI.Parser.Stream+ (T(..), run, runIncomplete, runPartial,+ ByteList(..),+ PossiblyIncomplete, UserMessage, ) where+++import Control.Monad.Trans.State+ (State, runState, evalState, get, put, )+import Control.Monad.Trans.Class (lift, )+import Control.Monad (liftM, when, ap, )+import Control.Applicative (Applicative, pure, (<*>), )++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.Parser.Exception as Exception+import qualified Sound.MIDI.Parser.Warning as Warning++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 :: Warning.T (State str) a}++++runPartial :: Parser.Fragile (T str) a -> str -> (Report.T a, str)+runPartial parser input =+ flip runState input $ Warning.run $ decons $ Exception.run parser++run :: ByteStream str => Parser.Fragile (T str) a -> str -> Report.T a+run parser input =+ flip evalState input $ Warning.run $ decons $ Exception.run $+ (do a <- parser+ lift $+ Parser.isEnd >>= \end ->+ Parser.warnIf (not end) "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 =>+ Parser.Partial (Parser.Fragile (T str)) a -> str -> Report.T a+runIncomplete parser input =+ flip run input $+ lift . Parser.warnIncomplete =<< parser++++fromState :: State str a -> T str a+fromState p =+ Cons $ lift p+++instance Functor (T str) where+ fmap = liftM++instance Applicative (T str) where+ pure = Cons . return+ (<*>) = ap++instance Monad (T str) where+ return = pure+ x >>= y = Cons $ decons . y =<< decons x+++class ByteStream str where+ switchL :: a -> (Word8 -> str -> a) -> str -> a+ drop :: NonNeg.Integer -> str -> str++newtype ByteList = ByteList MIO.ByteList+ deriving Show++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.EndCheck (T str) where+ isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get++instance ByteStream str => Parser.C (T str) where+ getByte =+ switchL+ (Parser.giveUp "unexpected end of data")+ (\s ss -> lift (fromState (put ss)) >> return s) =<<+ lift (fromState get)++{-+ skip n = sequence_ (genericReplicate n Parser.getByte)+-}+ skip n = when (n>0) $+ do s <- lift $ fromState get+ switchL+ (Parser.giveUp "skip past end of part")+ (\ _ rest -> lift $ fromState $ put rest)+ (drop (n-1) s)++ warn = Cons . Warning.warn+++{-+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)+-}
+ parser/Sound/MIDI/Parser/Warning.hs view
@@ -0,0 +1,28 @@+{- |+Handling of warnings.+-}+module Sound.MIDI.Parser.Warning where++import qualified Sound.MIDI.Parser.Report as Report++import qualified Control.Monad.Exception.Synchronous as Sync+import qualified Control.Monad.Trans.Writer as Writer+++type T m = Writer.WriterT [Report.UserMessage] m+++run :: Monad m =>+ T m (Sync.Exceptional Report.UserMessage a) -> m (Report.T a)+run act =+ do (exc,warns) <- Writer.runWriterT act+ return $ Report.Cons warns (Sync.toEither exc)++{-+run :: Monad m =>+ T m a -> m (a, [Report.UserMessage])+run = Writer.runWriterT+-}++warn :: Monad m => String -> T m ()+warn text = Writer.tell [text]
src/Sound/MIDI/Bit.hs view
@@ -14,8 +14,9 @@ module Sound.MIDI.Bit where -import Sound.MIDI.Utility (toMaybe, swap)-import Data.Word(Word8)+import Data.Maybe.HT (toMaybe, )+import Data.Tuple.HT (swap, )+import Data.Word (Word8, ) import qualified Data.List as List import qualified Data.Bits as Bits
src/Sound/MIDI/ControllerPrivate.hs view
@@ -5,7 +5,6 @@ enumRandomR, boundedEnumRandom, chooseEnum, ) import Test.QuickCheck (Arbitrary(arbitrary), )-import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), )
src/Sound/MIDI/Example/ControllerRamp.hs view
@@ -3,20 +3,14 @@ import qualified Sound.MIDI.File as MidiFile 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 Data.EventList.Relative.TimeBody as EventList--- import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.ByteString.Lazy as B---- import qualified Numeric.NonNegative.Wrapper as NonNeg
src/Sound/MIDI/Example/Tomatosalad.hs view
@@ -14,18 +14,12 @@ 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 Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.BodyTime as EventListBT import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Relative.TimeBody as EventList--- import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.ByteString.Lazy as B---- import qualified Numeric.NonNegative.Wrapper as NonNeg- import Data.Tuple.HT (mapFst, ) import qualified Control.Monad.Trans.State as State
src/Sound/MIDI/File.hs view
@@ -4,19 +4,19 @@ Taken from Haskore. -} -module Sound.MIDI.File(+module Sound.MIDI.File ( T(..), Division(..), Track, Type(..), empty, ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, explicitNoteOff, implicitNoteOff,- getTracks, mergeTracks,+ getTracks, mergeTracks, mapTrack, secondsFromTicks, ticksPerQuarterNote, showLines, changeVelocity, resampleTime, showEvent, showTime, sortEvents, progChangeBeforeSetTempo,- ) where+ ) where import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg@@ -32,12 +32,11 @@ import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Class as NonNeg -import Test.QuickCheck (Arbitrary(arbitrary), )+import Test.QuickCheck (Arbitrary(arbitrary, shrink), ) import qualified Test.QuickCheck as QC import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM, liftM2, )--- import Sound.MIDI.IO(ByteList) import Sound.MIDI.String (rightS, ) import Data.Ratio((%))@@ -77,12 +76,14 @@ [] division <- arbitrary return (Cons typ division content)+ shrink (Cons typ division tracks) =+ map (Cons typ division) $ shrink tracks instance Arbitrary Division where arbitrary = QC.oneof $- liftM (Ticks . (1+)) arbitrary :- liftM2 (\x y -> SMPTE (1+abs x) (1+abs y)) arbitrary arbitrary :+ liftM (Ticks . (1+) . flip mod 32767) arbitrary :+ liftM2 (\x y -> SMPTE (1 + mod x 127) (1 + mod y 255)) arbitrary arbitrary : [] @@ -133,8 +134,14 @@ Serial -> EventList.concat tracks {- |-Process and remove all @SetTempo@ events.+Process and remove all 'MetaEvent.SetTempo' events. The result is an event list where the times are measured in seconds.++Counterintuitively,+a 'MetaEvent.SetTempo' event sets the tempo for @all@ tracks.+This is important for Type-1 MIDI files (@Parallel@ tracks).+Thus you should apply 'secondsFromTicks' to the result of 'mergeTracks'+and not vice versa. -} secondsFromTicks :: Division ->@@ -142,7 +149,7 @@ EventList.T NonNegW.Rational Event.T secondsFromTicks division = EventList.catMaybes .- flip MS.evalState MetaEvent.defltST .+ flip MS.evalState MetaEvent.defltTempo . EventList.mapM (\ticks -> do microsPerQN <- MS.get
src/Sound/MIDI/File/Event.hs view
@@ -35,7 +35,7 @@ import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+))-import Sound.MIDI.Utility (mapSnd)+import Data.Tuple.HT (mapSnd) import Test.QuickCheck (Arbitrary(arbitrary), )@@ -83,7 +83,7 @@ -- * serialization -get :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T+get :: Parser.C parser => Parser.Fragile (StatusParser.T parser) T get = StatusParser.lift get1 >>= \tag -> if tag < 0xF0@@ -100,7 +100,7 @@ last event and the current event. Parse a time and an event, ignoring System Exclusive messages. -}-getTrackEvent :: Parser.C parser => Parser.Fallible (StatusParser.T parser) TrackEvent+getTrackEvent :: Parser.C parser => Parser.Fragile (StatusParser.T parser) TrackEvent getTrackEvent = liftM2 (,) (StatusParser.lift getVar) get @@ -109,9 +109,11 @@ into the raw data of a standard MIDI file. -} -put :: Writer.C writer => T -> StatusWriter.T writer+put ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ T -> StatusWriter.T compress writer put e = case e of- MIDIEvent m -> StatusWriter.lift (ChannelMsg.put m)+ MIDIEvent m -> ChannelMsg.putWithStatus m MetaEvent m -> StatusWriter.clear +#+ StatusWriter.lift (MetaEvent.put m) SystemExclusive m -> StatusWriter.clear +#+ StatusWriter.lift (SysEx.put m)
src/Sound/MIDI/File/Event/Meta.hs view
@@ -1,19 +1,20 @@ module Sound.MIDI.File.Event.Meta ( T(..),- Key(..), Scale(..), ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo,+ defltTempo, SMPTEHours, SMPTEMinutes, SMPTESeconds, SMPTEFrames, SMPTEBits,- defltST, defltDurT, get, put, ) where import Sound.MIDI.Message.Channel (Channel, toChannel, fromChannel, ) -import Sound.MIDI.Parser.Primitive+import qualified Sound.MIDI.KeySignature as KeySig++import Sound.MIDI.Parser.Primitive (get1, get2, get3, getVar, getBigN, ) import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as ParserRestricted -import Control.Monad (liftM, liftM2, liftM4, liftM5, )+import Control.Monad (liftM, liftM4, liftM5, ) import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit@@ -23,14 +24,11 @@ import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, listCharFromByte, listByteFromChar, ) -import Data.Ix (Ix, index, ) import Sound.MIDI.Utility- (arbitraryString, arbitraryByteList,- enumRandomR, boundedEnumRandom, chooseEnum, )+ (arbitraryString, arbitraryByteList, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC-import System.Random (Random(random, randomR), ) import Prelude hiding (putStr, ) @@ -59,7 +57,7 @@ | SetTempo Tempo | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits | TimeSig Int Int Int Int- | KeySig Key Scale+ | KeySig KeySig.T | SequencerSpecific ByteList | Unknown Int ByteList deriving (Show, Eq, Ord)@@ -81,7 +79,7 @@ liftM (SetTempo . NonNeg.fromNumberMsg "Tempo always positive") (QC.choose (0,0xFFFFFF)) : liftM5 SMPTEOffset arbitraryByte arbitraryByte arbitraryByte arbitraryByte arbitraryByte : liftM4 TimeSig arbitraryByte arbitraryByte arbitraryByte arbitraryByte :- liftM2 KeySig arbitrary arbitrary :+ liftM KeySig arbitrary : liftM SequencerSpecific arbitraryByteList : -- liftM Unknown arbitrary arbitraryByteList : []@@ -90,57 +88,6 @@ arbitraryByte = QC.choose (0,0xFF::Int) -{- |-The following enumerated type lists all the keys in order of their key-signatures from flats to sharps.-(@Cf@ = 7 flats, @Gf@ = 6 flats ... @F@ = 1 flat, @C@ = 0 flats\/sharps,-@G@ = 1 sharp, ... @Cs@ = 7 sharps.)-Useful for transposition.--}-data Key = KeyCf | KeyGf | KeyDf | KeyAf | KeyEf | KeyBf | KeyF- | KeyC | KeyG | KeyD | KeyA | KeyE | KeyB | KeyFs | KeyCs- deriving (Show, Eq, Ord, Ix, Enum, Bounded)---instance Random Key where- random = boundedEnumRandom- randomR = enumRandomR--instance Arbitrary Key where- arbitrary = chooseEnum----{- |-The Key Signature specifies a mode, either major or minor.--}-data Scale = Major | Minor- deriving (Show, Eq, Ord, Ix, Enum, Bounded)---instance Random Scale where- random = boundedEnumRandom- randomR = enumRandomR--instance Arbitrary Scale where- arbitrary = chooseEnum----{- |-Default number of quarter notes in a second.--}-defltDurT :: ElapsedTime-defltDurT = 2--{- |-The default SetTempo value, in microseconds per quarter note.-This expresses the default of 120 beats per minute.--}-defltST :: Tempo-defltST = div 1000000 (fromIntegral defltDurT)-- toElapsedTime :: Integer -> ElapsedTime toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime" @@ -154,15 +101,22 @@ fromTempo :: Tempo -> Int fromTempo = NonNeg.toNumber +{- |+The default SetTempo value, in microseconds per quarter note.+This expresses the default of 120 beats per minute.+-}+defltTempo :: Tempo+defltTempo = 500000 + -- * serialization -get :: Parser.C parser => Parser.Fallible parser T+get :: Parser.C parser => Parser.Fragile parser T get = do code <- get1 len <- getVar- let parse = ParserRestricted.runFallible len+ let parse = ParserRestricted.runFragile len let returnText cons = liftM (cons . listCharFromByte) $ getBigN len case code of 000 -> parse $ liftM SequenceNum get2@@ -193,21 +147,13 @@ b <- get1 return (TimeSig n d c b) - 089 -> parse $- do- sf <- get1- sc <- getEnum- return (KeySig (toKeyName sf) sc)+ 089 -> parse $ liftM KeySig KeySig.get 127 -> liftM SequencerSpecific $ getBigN len _ -> liftM (Unknown code) $ getBigN len -toKeyName :: Int -> Key-toKeyName sf = toEnum (mod (sf+7) 15) -- put :: Writer.C writer => T -> writer put ev = Writer.putByte 255 +#+@@ -227,11 +173,7 @@ SMPTEOffset hr mn se fr ff -> putList 84 [hr,mn,se,fr,ff] TimeSig n d c b -> putList 88 [n,d,c,b]- KeySig sf mi -> putList 89 [sf', fromEnum mi]- where k = index (KeyCf,KeyCs) sf - 7- sf' = if k >= 0- then k- else 255+k+ KeySig key -> putList 89 $ KeySig.toBytes key SequencerSpecific codes -> putByteList 127 codes Unknown typ s -> putByteList typ s
src/Sound/MIDI/File/Event/SystemExclusive.hs view
@@ -31,7 +31,7 @@ deriving (Show, Eq, Ord) -get :: Parser.C parser => Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Parser.Fragile parser T get tag = case tag of 0xF0 -> liftM Regular $ getBigN =<< getVar
src/Sound/MIDI/File/Load.hs view
@@ -12,10 +12,10 @@ But it seems to be not sensible to re-use functionality from the @iff@ package. -}-module Sound.MIDI.File.Load- (fromFile, fromByteList, maybeFromByteList, maybeFromByteString,- showFile, )- where+module Sound.MIDI.File.Load (+ fromFile, fromByteList, maybeFromByteList, maybeFromByteString,+ showFile,+ ) where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile@@ -26,7 +26,6 @@ import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, readBinaryFile, )--- import qualified Sound.MIDI.Bit as Bit import Sound.MIDI.String (unlinesS) import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser@@ -42,8 +41,6 @@ import qualified Data.ByteString.Lazy as B import qualified Control.Monad.Exception.Asynchronous as Async--- import qualified Control.Monad.Exception.Synchronous as Sync--- import System.IO (hPutStrLn, stderr, ) import Data.List (genericReplicate, genericLength, ) import Data.Maybe (catMaybes, ) @@ -101,13 +98,13 @@ 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 :: Parser.C parser => Parser.Partial (Parser.Fallible parser) MIDIFile.T+parse :: Parser.C parser => Parser.Partial (Parser.Fragile parser) MIDIFile.T parse = getChunk >>= \ (typ, hdLen) -> case typ of "MThd" -> do (format, nTracks, division) <-- RestrictedParser.runFallible hdLen getHeader+ RestrictedParser.runFragile hdLen getHeader excTracks <- lift $ Parser.zeroOrMoreInc (getTrackChunk >>= Async.mapM (lift . liftMaybe removeEndOfTrack))@@ -177,14 +174,14 @@ four bytes for the size of the coming data, and the data itself. -}-getChunk :: Parser.C parser => Parser.Fallible parser (String, NonNeg.Integer)+getChunk :: Parser.C parser => Parser.Fragile parser (String, NonNeg.Integer) getChunk = liftM2 (,) (getString 4) -- chunk type: header or track (getNByteCardinal 4) -- chunk body -getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fallible parser) (Maybe Track)+getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fragile parser) (Maybe Track) getTrackChunk = do (typ, len) <- getChunk if typ=="MTrk"@@ -202,7 +199,7 @@ the number of track chunks to come, and the smallest time division to be used in reading the rest of the file. -}-getHeader :: Parser.C parser => Parser.Fallible parser (MIDIFile.Type, NonNeg.Int, Division)+getHeader :: Parser.C parser => Parser.Fragile parser (MIDIFile.Type, NonNeg.Int, Division) getHeader = do format <- makeEnum =<< get2@@ -214,7 +211,7 @@ 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 :: Parser.C parser => Parser.Fallible parser Division+getDivision :: Parser.C parser => Parser.Fragile parser Division getDivision = do x <- get1@@ -273,7 +270,7 @@ showString "\n" -showMR :: Parser.Fallible (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS+showMR :: Parser.Fragile (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS showMR m pp contents = let report = StreamParser.run m (StreamParser.ByteList contents) in unlinesS (map showString $ Report.warnings report) .
src/Sound/MIDI/File/Save.hs view
@@ -19,11 +19,10 @@ import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic as Writer-import qualified Sound.MIDI.Monoid as M import Sound.MIDI.Monoid ((+#+)) -import qualified Data.Monoid.Reader as Reader import qualified Data.Monoid.Transformer as Trans+import Data.Foldable (foldMap, ) import Sound.MIDI.IO (ByteList, writeBinaryFile, ) @@ -81,13 +80,15 @@ -put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer+put ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ MIDIFile.T -> StatusWriter.T compress writer put (MIDIFile.Cons mft divisn trks) = (putChunk "MThd" $ StatusWriter.lift $ 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- +#+ M.concatMap putTrack trks+ +#+ foldMap putTrack trks putDivision :: Writer.C writer => Division -> writer putDivision (Ticks nticks) =@@ -96,7 +97,9 @@ Writer.putIntAsByte (256-mode) +#+ Writer.putIntAsByte nticks -putTrack :: Writer.C writer => Track -> StatusWriter.T writer+putTrack ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ Track -> StatusWriter.T compress writer putTrack trk = putChunk "MTrk" $ EventList.concatMapMonoid (StatusWriter.lift . Writer.putVar) Event.put $@@ -104,13 +107,13 @@ -putChunk :: Writer.C writer =>- String -> StatusWriter.T writer -> StatusWriter.T writer+putChunk ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ String -> StatusWriter.T compress writer -> StatusWriter.T compress writer putChunk tag m = StatusWriter.lift (putTag tag) +#+- StatusWriter.Cons (Reader.Cons $ \compress ->- Trans.lift $ Writer.putLengthBlock 4 $- StatusWriter.toWriter compress m)+ (StatusWriter.Cons $ Trans.lift $+ Writer.putLengthBlock 4 $ StatusWriter.toWriter m) putTag :: Writer.C writer => String -> writer
src/Sound/MIDI/General.hs view
@@ -11,8 +11,9 @@ import Data.Ix(Ix) import qualified Data.List as List -import Sound.MIDI.Utility (mapSnd,- enumRandomR, boundedEnumRandom, chooseEnum, )+import Sound.MIDI.Utility+ (enumRandomR, boundedEnumRandom, chooseEnum, )+import Data.Tuple.HT (mapSnd, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import System.Random (Random(random,randomR), )
src/Sound/MIDI/IO.hs view
@@ -15,6 +15,7 @@ type ByteList = [Word8] {- |+FixMe: 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).ByteList.Lazy,
+ src/Sound/MIDI/KeySignature.hs view
@@ -0,0 +1,182 @@+module Sound.MIDI.KeySignature (+ T(..),+ Accidentals(..), Mode(..), keyName,++ cfMajor, gfMajor, dfMajor, afMajor, efMajor,+ bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor,+ eMajor, bMajor, fsMajor, csMajor,+ afMinor, efMinor, bfMinor, fMinor, cMinor,+ gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor,+ csMinor, gsMinor, dsMinor, asMinor,++ get, toBytes, ) where++import Sound.MIDI.Parser.Primitive (getByte, getEnum, makeEnum, )+import qualified Sound.MIDI.Parser.Class as Parser++import Control.Monad (liftM2, )++import Data.Ix (Ix, inRange, )+import Sound.MIDI.Utility+ (enumRandomR, boundedEnumRandom, chooseEnum, checkRange, )++import Test.QuickCheck (Arbitrary(arbitrary), )+import System.Random (Random(random, randomR), )++import Data.Int (Int8, )++import Prelude hiding (putStr, )++++data T = Cons Mode Accidentals+ deriving (Eq, Ord)++instance Show T where+ showsPrec p (Cons mode accs) =+ if inRange (minBound, maxBound) accs+ then showString "KeySig." .+ showString (keyName mode accs) . shows mode+ else showParen (p>10) $+ showString "KeySig.Cons " . shows mode .+ showString " " . showsPrec 11 accs++instance Arbitrary T where+ arbitrary = liftM2 Cons arbitrary arbitrary++{- |+The Key Signature specifies a mode, either major or minor.+-}+data Mode = Major | Minor+ deriving (Show, Eq, Ord, Ix, Enum, Bounded)+++instance Random Mode where+ random = boundedEnumRandom+ randomR = enumRandomR++instance Arbitrary Mode where+ arbitrary = chooseEnum++++++keyName :: Mode -> Accidentals -> String++keyName Major (Accidentals (-7)) = "cf"+keyName Major (Accidentals (-6)) = "gf"+keyName Major (Accidentals (-5)) = "df"+keyName Major (Accidentals (-4)) = "af"+keyName Major (Accidentals (-3)) = "ef"+keyName Major (Accidentals (-2)) = "bf"+keyName Major (Accidentals (-1)) = "f"+keyName Major (Accidentals 0) = "c"+keyName Major (Accidentals 1) = "g"+keyName Major (Accidentals 2) = "d"+keyName Major (Accidentals 3) = "a"+keyName Major (Accidentals 4) = "e"+keyName Major (Accidentals 5) = "b"+keyName Major (Accidentals 6) = "fs"+keyName Major (Accidentals 7) = "cs"++keyName Minor (Accidentals (-7)) = "af"+keyName Minor (Accidentals (-6)) = "ef"+keyName Minor (Accidentals (-5)) = "bf"+keyName Minor (Accidentals (-4)) = "f"+keyName Minor (Accidentals (-3)) = "c"+keyName Minor (Accidentals (-2)) = "g"+keyName Minor (Accidentals (-1)) = "d"+keyName Minor (Accidentals 0) = "a"+keyName Minor (Accidentals 1) = "e"+keyName Minor (Accidentals 2) = "b"+keyName Minor (Accidentals 3) = "fs"+keyName Minor (Accidentals 4) = "cs"+keyName Minor (Accidentals 5) = "gs"+keyName Minor (Accidentals 6) = "ds"+keyName Minor (Accidentals 7) = "as"++keyName _ (Accidentals n) =+ if n<0+ then show (-n) ++ " flats"+ else show n ++ " sharps"+++{- |+Accidentals as used in key signature.+-}+newtype Accidentals = Accidentals Int+ deriving (Show, Eq, Ord, Ix)++instance Bounded Accidentals where+ minBound = Accidentals (-7)+ maxBound = Accidentals 7++instance Enum Accidentals where+ fromEnum (Accidentals n) = fromIntegral n+ toEnum = checkRange "Accidentals" (Accidentals . fromIntegral)++instance Random Accidentals where+ random = boundedEnumRandom+ randomR = enumRandomR++instance Arbitrary Accidentals where+ arbitrary = chooseEnum+++++major, minor :: Accidentals -> T+major = Cons Major+minor = Cons Minor++cfMajor, gfMajor, dfMajor, afMajor, efMajor,+ bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor,+ eMajor, bMajor, fsMajor, csMajor :: T++afMinor, efMinor, bfMinor, fMinor, cMinor,+ gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor,+ csMinor, gsMinor, dsMinor, asMinor :: T++cfMajor = major (Accidentals (-7))+gfMajor = major (Accidentals (-6))+dfMajor = major (Accidentals (-5))+afMajor = major (Accidentals (-4))+efMajor = major (Accidentals (-3))+bfMajor = major (Accidentals (-2))+fMajor = major (Accidentals (-1))+cMajor = major (Accidentals 0)+gMajor = major (Accidentals 1)+dMajor = major (Accidentals 2)+aMajor = major (Accidentals 3)+eMajor = major (Accidentals 4)+bMajor = major (Accidentals 5)+fsMajor = major (Accidentals 6)+csMajor = major (Accidentals 7)++afMinor = minor (Accidentals (-7))+efMinor = minor (Accidentals (-6))+bfMinor = minor (Accidentals (-5))+fMinor = minor (Accidentals (-4))+cMinor = minor (Accidentals (-3))+gMinor = minor (Accidentals (-2))+dMinor = minor (Accidentals (-1))+aMinor = minor (Accidentals 0)+eMinor = minor (Accidentals 1)+bMinor = minor (Accidentals 2)+fsMinor = minor (Accidentals 3)+csMinor = minor (Accidentals 4)+gsMinor = minor (Accidentals 5)+dsMinor = minor (Accidentals 6)+asMinor = minor (Accidentals 7)+++get :: (Parser.C parser) => Parser.Fragile parser T+get = liftM2 (flip Cons) getAccidentals getEnum++getAccidentals :: (Parser.C parser) => Parser.Fragile parser Accidentals+getAccidentals =+ makeEnum . fromIntegral . (id :: Int8 -> Int8) . fromIntegral =<< getByte++toBytes :: T -> [Int]+toBytes (Cons mi sf) = [fromEnum sf, fromEnum mi]
+ src/Sound/MIDI/MachineControl.hs view
@@ -0,0 +1,198 @@+module Sound.MIDI.MachineControl (+ splitCommandList,++ getCommand,+ getCommands,++ Command (+ Stop,+ Play,+ DeferredPlay,+ FastForward,+ Rewind,+ RecordStrobe,+ RecordExit,+ RecordPause,+ Pause,+ Eject,+ Chase,+ CommandErrorReset,+ Reset,+ Wait,+ Resume+ {-+ I will export more constructors, when I am sure,+ that their definition is reasonable.+ -}+ ),++ runParser,++ ) where++import Sound.MIDI.Parser.Primitive+import qualified Sound.MIDI.Parser.Class as Parser+import qualified Sound.MIDI.Parser.Stream as SP++import Sound.MIDI.IO (ByteList, )++import qualified Numeric.NonNegative.Wrapper as NonNeg++import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM, liftM2, liftM3, )++import Data.List (unfoldr, )+import Data.Tuple.HT (mapFst, )+import Data.Bool.HT (if', )+import Data.Word (Word8, )+import Data.Maybe (isNothing, catMaybes, )+++-- * serialization++splitCommandList :: [Word8] -> [(Word8, [Word8])]+splitCommandList =+ unfoldr $ \xt ->+ case xt of+ [] -> Nothing+ x:xs ->+ Just $ (mapFst ((,) x)) $+ if' (x==0 || x==0xF7) (xs, []) $+ if' (0x40 <= x && x < 0x78)+ (case xs of+ [] -> ([], [])+ n:ys -> splitAt (fromIntegral n) ys) $+ ([], xs)+++data Command =+ Stop+ | Play+ | DeferredPlay+ | FastForward+ | Rewind+ | RecordStrobe+ | RecordExit+ | RecordPause+ | Pause+ | Eject+ | Chase+ | CommandErrorReset+ | Reset++ | Write ByteList+ | MaskedWrite ByteList+ | Read ByteList+ | Update ByteList+ | Locate ByteList+ | VariablePlay Word8 Word8 Word8+ | Search Word8 Word8 Word8+ | Shuttle Word8 Word8 Word8+ | Step Word8+ | AssignSystemMaster Word8+ | GeneratorCommand Word8+ | MIDITimeCodeCommand Word8+ | Move Word8 Word8+ | Add Word8 Word8 Word8+ | Subtract Word8 Word8 Word8+ | DropFrameAdjust Word8+ | Procedure ByteList+ | Event ByteList+ | Group ByteList+ | CommandSegment ByteList+ | DeferredVariablePlay ByteList+ | RecordStrobeVariable ByteList++ | Wait+ | Resume++ | GenericNoData Word8+ | GenericVariableLength Word8 ByteList+ deriving (Show)+++{- |+Read MIDI machine control commands+until an F7 marker for SysEx end.+-}+getCommands :: Parser.C parser => Parser.Partial parser [Command]+getCommands =+ liftM (fmap catMaybes) $+ Parser.until isNothing $ do+ code <- getByte+ if code == 0xF7+ then return Nothing+ else liftM Just $ getCommand code++getCommand :: Parser.C parser => Word8 -> Parser.Fragile parser Command+getCommand code =+ let fetchMany f = liftM f $ getN . NonNeg.fromNumberMsg "Midi.get1" =<< get1+ fetchN reqLen act = do+ len <- get1+ if len==reqLen+ then act+ else Parser.giveUp $+ "expect " ++ show reqLen +++ " argument(s) for command " ++ show code +++ ", but got " ++ show len+ fetch1 f = fetchN 1 (liftM f getByte)+ fetch2 f = fetchN 2 (liftM2 f getByte getByte)+ fetch3 f = fetchN 3 (liftM3 f getByte getByte getByte)++ in case code of+ 0x01 -> return Stop+ 0x02 -> return Play+ 0x03 -> return DeferredPlay+ 0x04 -> return FastForward+ 0x05 -> return Rewind+ 0x06 -> return RecordStrobe+ 0x07 -> return RecordExit+ 0x08 -> return RecordPause+ 0x09 -> return Pause+ 0x0A -> return Eject+ 0x0B -> return Chase+ 0x0C -> return CommandErrorReset+ 0x0D -> return Reset++ 0x40 -> fetchMany Write+ 0x41 -> fetchMany MaskedWrite+ 0x42 -> fetchMany Read+ 0x43 -> fetchMany Update+ 0x44 -> fetchMany Locate+ 0x45 -> fetch3 VariablePlay+ 0x46 -> fetch3 Search+ 0x47 -> fetch3 Shuttle+ 0x48 -> fetch1 Step+ 0x49 -> fetch1 AssignSystemMaster+ 0x4A -> fetch1 GeneratorCommand+ 0x4B -> fetch1 MIDITimeCodeCommand+ 0x4C -> fetch2 Move+ 0x4D -> fetch3 Add+ 0x4E -> fetch3 Subtract+ 0x4F -> fetch1 DropFrameAdjust+ 0x50 -> fetchMany Procedure+ 0x51 -> fetchMany Event+ 0x52 -> fetchMany Group+ 0x53 -> fetchMany CommandSegment+ 0x54 -> fetchMany DeferredVariablePlay+ 0x55 -> fetchMany RecordStrobeVariable++ 0x7C -> return Wait+ 0x7F -> return Resume++ 0x00 -> Parser.giveUp "encountered command zero"+ 0xF7 -> Parser.giveUp "end of SysEx" -- should be handled by the caller++ _ ->+ if' (0x40 <= code && code < 0x78)+ (fetchMany $ GenericVariableLength code)+ (return $ GenericNoData code)++runParser ::+ Parser.Partial (SP.T SP.ByteList) a ->+ ByteList ->+ (SP.PossiblyIncomplete a, [SP.UserMessage])+runParser p =+ MS.evalState (MW.runWriterT $ SP.decons p) .+ SP.ByteList
src/Sound/MIDI/Manufacturer.hs view
@@ -350,7 +350,7 @@ -- * serialization -get :: Parser.C parser => Parser.Fallible parser T+get :: Parser.C parser => Parser.Fragile parser T get = do subId <- getByte if subId == 0
src/Sound/MIDI/Message.hs view
@@ -34,9 +34,11 @@ data T = Channel Channel.T | System System.T+-- Show instance requires Show instance of System.T+-- deriving (Show) -get :: Parser.C parser => Parser.Fallible parser T+get :: Parser.C parser => Parser.Fragile parser T get = get1 >>= \code -> if code >= 0xF0@@ -44,7 +46,7 @@ else liftM Channel $ (uncurry Channel.get (Channel.decodeStatus code) =<< get1) -- else liftM Channel $ StatusParser.run (Channel.getWithStatus code) -getWithStatus :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T+getWithStatus :: Parser.C parser => Parser.Fragile (StatusParser.T parser) T getWithStatus = StatusParser.lift get1 >>= \code -> if code >= 0xF0@@ -53,7 +55,7 @@ else liftM Channel $ Channel.getWithStatus code getIncompleteWithStatus ::- Parser.C parser => Parser.Partial (Parser.Fallible (StatusParser.T parser)) T+ Parser.C parser => Parser.Partial (Parser.Fragile (StatusParser.T parser)) T getIncompleteWithStatus = StatusParser.lift get1 >>= \code -> if code >= 0xF0@@ -73,7 +75,9 @@ Channel s -> Channel.put s System s -> System.put s -putWithStatus :: Writer.C writer => T -> StatusWriter.T writer+putWithStatus ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ T -> StatusWriter.T compress writer putWithStatus msg = case msg of Channel s -> Channel.putWithStatus s
src/Sound/MIDI/Message/Channel.hs view
@@ -19,8 +19,7 @@ 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- (Channel, fromChannel, toChannel, )+import Sound.MIDI.Parser.Status (Channel, fromChannel, toChannel, ) import Control.Monad (liftM, liftM2, when, ) @@ -30,10 +29,9 @@ import Sound.MIDI.Monoid ((+#+)) -import Sound.MIDI.Utility ({-checkRange,-} mapSnd, )--- import Data.Ix (Ix)+import Data.Tuple.HT (mapSnd, ) -import Test.QuickCheck (Arbitrary(arbitrary), )+import Test.QuickCheck (Arbitrary(arbitrary, shrink), ) import qualified Test.QuickCheck as QC @@ -42,6 +40,7 @@ messageChannel :: Channel, messageBody :: Body }+ -- ToDo: make nicer Show instance deriving (Show, Eq, Ord) data Body =@@ -61,6 +60,11 @@ (20, liftM Voice arbitrary) : ( 1, liftM Mode arbitrary) : [])+ shrink (Cons chan body) =+ map (uncurry Cons) $+ case body of+ Voice v -> map (mapSnd Voice) $ shrink (chan, v)+ Mode m -> map (mapSnd Mode) $ shrink (chan, m) -- * serialization@@ -74,7 +78,7 @@ (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 -> Parser.Fallible (StatusParser.T parser) T+getWithStatus :: Parser.C parser => Int -> Parser.Fragile (StatusParser.T parser) T getWithStatus tag = do (status@(code, channel), firstData) <- if tag < 0x80@@ -97,7 +101,7 @@ the code, channel and first data byte must be determined by the caller. -}-get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fragile parser T get code channel firstData = liftM (Cons channel) $ if code == 11 && firstData >= 0x78@@ -111,14 +115,18 @@ put :: Writer.C writer => T -> writer put = StatusWriter.toWriterWithoutStatus . putWithStatus -putWithStatus :: Writer.C writer => T -> StatusWriter.T writer+putWithStatus ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ T -> StatusWriter.T compress writer putWithStatus (Cons c e) = case e of Voice v -> Voice.putWithStatus (putChannel c) v Mode m -> putChannel c 11 +#+ StatusWriter.lift (Mode.put m) -- | output a channel + message code-putChannel :: Writer.C writer => Channel -> Int -> StatusWriter.T writer+putChannel ::+ (StatusWriter.Compression compress, Writer.C writer) =>+ Channel -> Int -> StatusWriter.T compress writer putChannel chan code =- StatusWriter.change (Just (code, chan)) $+ StatusWriter.change (code, chan) $ Writer.putIntAsByte (16*code + fromChannel chan)
src/Sound/MIDI/Message/Channel/Mode.hs view
@@ -13,7 +13,7 @@ import Sound.MIDI.Parser.Report (UserMessage, ) import qualified Control.Monad.Exception.Asynchronous as Async-import Sound.MIDI.Utility (toMaybe, )+import Data.Maybe.HT (toMaybe, ) import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, ) @@ -47,7 +47,7 @@ -- * serialization -get :: Parser.C parser => Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Parser.Fragile parser T get mode = do x <- get1 lift $ Parser.warnIncomplete $ uncurry Async.Exceptional $ fromControllerValue (mode,x)
src/Sound/MIDI/Message/Channel/Voice.hs view
@@ -6,7 +6,7 @@ ControllerValue, PitchBendRange, Pressure, isNote, isNoteOn, isNoteOff, zeroKey, explicitNoteOff, implicitNoteOff,- toFloatController,+ realFromControllerValue, bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, mainVolume, balance, panorama, expression,@@ -35,7 +35,7 @@ CtrlP.Controller, CtrlP.fromController, CtrlP.toController, increasePitch, subtractPitch, frequencyFromPitch,- maximumVelocity, normalVelocity, toFloatVelocity,+ maximumVelocity, normalVelocity, realFromVelocity, ) where import qualified Sound.MIDI.ControllerPrivate as CtrlP@@ -223,6 +223,14 @@ minBound = Pitch 0 maxBound = Pitch 127 +{- |+ToDo:+We have defined minBound = Velocity 0,+but strictly spoken the minimum Velocity is 1,+since Velocity zero means NoteOff.+One can at least think of NoteOff with (Velocity 0),+but I have never seen that.+-} instance Bounded Velocity where minBound = Velocity 0 maxBound = Velocity 127@@ -249,33 +257,28 @@ {- | The velocity of an ordinary key stroke and the maximum possible velocity.--ToDo:-This should be of type Velocity. -}-normalVelocity, maximumVelocity :: Num quant => quant- -- Velocity-normalVelocity = 64-maximumVelocity = 127+normalVelocity, maximumVelocity :: Velocity+normalVelocity = Velocity 64+maximumVelocity = maxBound {- |-64 is given as default value by the MIDI specification-and thus we map it to 1.-0 is mapped to 0.-All other values are interpolated linearly.--ToDo: MIDI specification says, if velocity is simply mapped to amplitude, then this should be done by an exponential function.-Thus we should be better map 'normalVelocity' to 0,-'maximumVelocity' to 1,-and 'minimumVelocity' to -1.+Thus we map 'normalVelocity' (64) to 0,+'maximumVelocity' (127) to 1,+and 'minimumVelocity' (1) to -1.+That is, normally you should write something like+@amplitude = 2 ** realFromVelocity vel@ or @3 ** realFromVelocity vel@. -}-toFloatVelocity :: (Integral a, Fractional b) => a -> b-toFloatVelocity x = fromIntegral x / normalVelocity+realFromVelocity :: (Fractional b) => Velocity -> b+realFromVelocity (Velocity x) =+ fromIntegral (x - fromVelocity normalVelocity) /+ fromIntegral (fromVelocity maximumVelocity - fromVelocity normalVelocity) -maximumControllerValue :: Num quant => quant++maximumControllerValue :: Num a => a maximumControllerValue = 127 {- |@@ -283,8 +286,8 @@ Maximum integral MIDI controller value 127 is mapped to 1. Minimum integral MIDI controller value 0 is mapped to 0. -}-toFloatController :: (Integral a, Fractional b) => a -> b-toFloatController x = fromIntegral x / maximumControllerValue+realFromControllerValue :: (Integral a, Fractional b) => a -> b+realFromControllerValue x = fromIntegral x / maximumControllerValue @@ -403,7 +406,7 @@ -- * serialization -get :: Parser.C parser => Int -> Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Int -> Parser.Fragile parser T get code firstData = let pitch = toPitch firstData getVel = liftM toVelocity get1@@ -423,7 +426,8 @@ putWithStatus :: Writer.C writer =>- (Int -> StatusWriter.T writer) -> T -> StatusWriter.T writer+ (Int -> StatusWriter.T compress writer) ->+ T -> StatusWriter.T compress writer putWithStatus putChan e = let putC code bytes = putChan code +#+
src/Sound/MIDI/Message/Class/Check.hs view
@@ -1,17 +1,41 @@-module Sound.MIDI.Message.Class.Check where+module Sound.MIDI.Message.Class.Check (+ C(..),+ noteExplicitOff,+ noteImplicitOff,+ controller,+ liftMidi,+ liftFile,+ ) where +import qualified Sound.MIDI.Message.Class.Utility as CU+ import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, ) +import qualified Sound.MIDI.File.Event as FileEvent import qualified Sound.MIDI.Message as MidiMsg import qualified Sound.MIDI.Message.Channel as ChannelMsg-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode import Control.Monad (guard, ) +{- |+All methods have default implementations that return 'Nothing'.+This helps implementing event data types+that support only a subset of types of events.++Maybe a better approach is to provide type classes+for every type of event+and make 'C' a subclass of all of them.+-} class C event where+ {- |+ Warning: This returns note events as they are,+ that is, a @NoteOff p 64@ might be encoded as such or as @NoteOn p 0@+ depending on the content of @event@.+ For normalized results you may use 'noteExplicitOff'.+ -} note :: Channel -> event -> Maybe (Velocity, Pitch, Bool) program :: Channel -> event -> Maybe Program anyController :: Channel -> event -> Maybe (Controller, Int)@@ -19,6 +43,35 @@ channelPressure :: Channel -> event -> Maybe Int mode :: Channel -> event -> Maybe Mode.T + note _chan _ev = Nothing+ program _chan _ev = Nothing+ anyController _chan _ev = Nothing+ pitchBend _chan _ev = Nothing+ channelPressure _chan _ev = Nothing+ mode _chan _ev = Nothing+++{- |+Like 'note', but converts @NoteOn p 0@ to @NoteOff p 64@.+See 'VoiceMsg.explicitNoteOff'.+-}+noteExplicitOff ::+ (C event) =>+ Channel -> event -> Maybe (Velocity, Pitch, Bool)+noteExplicitOff chan e =+ fmap CU.explicitNoteOff $ note chan e++{- |+Like 'note', but converts @NoteOff p 64@ to @NoteOn p 0@.+See 'VoiceMsg.implicitNoteOff'.+-}+noteImplicitOff ::+ (C event) =>+ Channel -> event -> Maybe (Velocity, Pitch, Bool)+noteImplicitOff chan e =+ fmap CU.implicitNoteOff $ note chan e++ controller :: (C event) => Channel -> Controller -> event -> Maybe Int@@ -28,44 +81,20 @@ return n -instance C ChannelMsg.T where- note chan msg = do- guard (ChannelMsg.messageChannel msg == chan)- ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg- case voice of- VoiceMsg.NoteOn pitch velocity -> Just (velocity, pitch, True)- VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False)- _ -> Nothing-- program chan msg = do- guard (ChannelMsg.messageChannel msg == chan)- ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <-- Just $ ChannelMsg.messageBody msg- return pgm-- anyController chan msg = do- guard (ChannelMsg.messageChannel msg == chan)- ChannelMsg.Voice (VoiceMsg.Control ctrl val) <-- Just $ ChannelMsg.messageBody msg- return (ctrl, val)-- pitchBend chan msg = do- guard (ChannelMsg.messageChannel msg == chan)- ChannelMsg.Voice (VoiceMsg.PitchBend bend) <-- Just $ ChannelMsg.messageBody msg- return bend-- channelPressure chan msg = do- guard (ChannelMsg.messageChannel msg == chan)- ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <-- Just $ ChannelMsg.messageBody msg- return pressure+lift ::+ (Maybe ChannelMsg.Body -> Maybe a) ->+ Channel -> ChannelMsg.T -> Maybe a+lift act chan msg = do+ guard (ChannelMsg.messageChannel msg == chan)+ act $ Just $ ChannelMsg.messageBody msg - mode chan msg = do- guard (ChannelMsg.messageChannel msg == chan)- ChannelMsg.Mode m <-- Just $ ChannelMsg.messageBody msg- return m+instance C ChannelMsg.T where+ note = lift CU.note+ program = lift CU.program+ anyController = lift CU.anyController+ pitchBend = lift CU.pitchBend+ channelPressure = lift CU.channelPressure+ mode = lift CU.mode liftMidi ::@@ -83,3 +112,20 @@ pitchBend = liftMidi pitchBend channelPressure = liftMidi channelPressure mode = liftMidi mode+++liftFile ::+ (Channel -> ChannelMsg.T -> Maybe a) ->+ (Channel -> FileEvent.T -> Maybe a)+liftFile checkMsg chan msg =+ case msg of+ FileEvent.MIDIEvent midiMsg -> checkMsg chan midiMsg+ _ -> Nothing++instance C FileEvent.T where+ note = liftFile note+ program = liftFile program+ anyController = liftFile anyController+ pitchBend = liftFile pitchBend+ channelPressure = liftFile channelPressure+ mode = liftFile mode
+ src/Sound/MIDI/Message/Class/Construct.hs view
@@ -0,0 +1,111 @@+module Sound.MIDI.Message.Class.Construct where++import qualified Sound.MIDI.Message.Class.Utility as CU++import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )++import qualified Sound.MIDI.File.Event as FileEvent+import qualified Sound.MIDI.Message as MidiMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode+++class C event where+ {- |+ Warning: This constructs a note events as is,+ that is, a @NoteOff p 64@ is encoded as such+ and will not be converted to @NoteOn p 0@.+ If you want such a conversion, you may use 'noteImplicitOff'.+ -}+ note :: Channel -> (Velocity, Pitch, Bool) -> event+ program :: Channel -> Program -> event+ anyController :: Channel -> (Controller, Int) -> event+ pitchBend :: Channel -> Int -> event+ channelPressure :: Channel -> Int -> event+ mode :: Channel -> Mode.T -> event+++liftChannel ::+ (a -> ChannelMsg.Body) ->+ (Channel -> a -> ChannelMsg.T)+liftChannel makeMsg channel param =+ ChannelMsg.Cons channel $ makeMsg param++instance C ChannelMsg.T where+ note =+ liftChannel $ \(velocity, pitch, on) ->+ ChannelMsg.Voice $+ (if on then VoiceMsg.NoteOn else VoiceMsg.NoteOff) pitch velocity++ program =+ liftChannel $ \pgm ->+ ChannelMsg.Voice $ VoiceMsg.ProgramChange pgm++ anyController =+ liftChannel $ \(ctrl, val) ->+ ChannelMsg.Voice $ VoiceMsg.Control ctrl val++ pitchBend =+ liftChannel $ \bend ->+ ChannelMsg.Voice $ VoiceMsg.PitchBend bend++ channelPressure =+ liftChannel $ \pressure ->+ ChannelMsg.Voice $ VoiceMsg.MonoAftertouch pressure++ mode =+ liftChannel $ \m ->+ ChannelMsg.Mode m+++{- |+Like 'note', but converts @NoteOn p 0@ to @NoteOff p 64@.+See 'VoiceMsg.explicitNoteOff'.+-}+noteExplicitOff ::+ (C event) =>+ Channel -> (Velocity, Pitch, Bool) -> event+noteExplicitOff channel =+ note channel . CU.explicitNoteOff++{- |+Like 'note', but converts @NoteOff p 64@ to @NoteOn p 0@.+See 'VoiceMsg.implicitNoteOff'.+-}+noteImplicitOff ::+ (C event) =>+ Channel -> (Velocity, Pitch, Bool) -> event+noteImplicitOff channel =+ note channel . CU.implicitNoteOff+++liftMidi ::+ (Channel -> a -> ChannelMsg.T) ->+ (Channel -> a -> MidiMsg.T)+liftMidi makeMsg channel msg =+ MidiMsg.Channel $ makeMsg channel msg++instance C MidiMsg.T where+ note = liftMidi note+ program = liftMidi program+ anyController = liftMidi anyController+ pitchBend = liftMidi pitchBend+ channelPressure = liftMidi channelPressure+ mode = liftMidi mode+++liftFile ::+ (Channel -> a -> ChannelMsg.T) ->+ (Channel -> a -> FileEvent.T)+liftFile makeMsg channel msg =+ FileEvent.MIDIEvent $ makeMsg channel msg++instance C FileEvent.T where+ note = liftFile note+ program = liftFile program+ anyController = liftFile anyController+ pitchBend = liftFile pitchBend+ channelPressure = liftFile channelPressure+ mode = liftFile mode
+ src/Sound/MIDI/Message/Class/Query.hs view
@@ -0,0 +1,120 @@+module Sound.MIDI.Message.Class.Query (+ C(..),+ noteExplicitOff,+ noteImplicitOff,+ liftMidi,+ liftFile,+ ) where++import qualified Sound.MIDI.Message.Class.Utility as CU++import Sound.MIDI.Message.Channel (Channel, )+import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )++import qualified Sound.MIDI.File.Event as FileEvent+import qualified Sound.MIDI.Message as MidiMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode++import Data.Tuple.HT (mapSnd, )+++{- |+All methods have default implementations that return 'Nothing'.+This helps implementing event data types+that support only a subset of types of events.++Maybe a better approach is to provide type classes+for every type of event+and make 'C' a subclass of all of them.+-}+class C event where+ {- |+ Warning: This returns note events as they are,+ that is, a @NoteOff p 64@ might be encoded as such or as @NoteOn p 0@+ depending on the content of @event@.+ For normalized results you may use 'noteExplicitOff'.+ -}+ note :: event -> Maybe (Channel, (Velocity, Pitch, Bool))+ program :: event -> Maybe (Channel, Program)+ anyController :: event -> Maybe (Channel, (Controller, Int))+ pitchBend :: event -> Maybe (Channel, Int)+ channelPressure :: event -> Maybe (Channel, Int)+ mode :: event -> Maybe (Channel, Mode.T)++ note _ev = Nothing+ program _ev = Nothing+ anyController _ev = Nothing+ pitchBend _ev = Nothing+ channelPressure _ev = Nothing+ mode _ev = Nothing+++lift ::+ (Maybe ChannelMsg.Body -> Maybe a) ->+ ChannelMsg.T -> Maybe (Channel, a)+lift act msg =+ fmap ((,) (ChannelMsg.messageChannel msg)) $+ act $ Just $ ChannelMsg.messageBody msg++instance C ChannelMsg.T where+ note = lift CU.note+ program = lift CU.program+ anyController = lift CU.anyController+ pitchBend = lift CU.pitchBend+ channelPressure = lift CU.channelPressure+ mode = lift CU.mode++{- |+Like 'note', but converts @NoteOn p 0@ to @NoteOff p 64@.+See 'VoiceMsg.explicitNoteOff'.+-}+noteExplicitOff ::+ (C event) =>+ event -> Maybe (Channel, (Velocity, Pitch, Bool))+noteExplicitOff e =+ fmap (mapSnd CU.explicitNoteOff) $ note e++{- |+Like 'note', but converts @NoteOff p 64@ to @NoteOn p 0@.+See 'VoiceMsg.implicitNoteOff'.+-}+noteImplicitOff ::+ (C event) =>+ event -> Maybe (Channel, (Velocity, Pitch, Bool))+noteImplicitOff e =+ fmap (mapSnd CU.implicitNoteOff) $ note e+++liftMidi ::+ (ChannelMsg.T -> Maybe (Channel, a)) ->+ (MidiMsg.T -> Maybe (Channel, a))+liftMidi checkMsg msg =+ case msg of+ MidiMsg.Channel chanMsg -> checkMsg chanMsg+ _ -> Nothing++instance C MidiMsg.T where+ note = liftMidi note+ program = liftMidi program+ anyController = liftMidi anyController+ pitchBend = liftMidi pitchBend+ channelPressure = liftMidi channelPressure+ mode = liftMidi mode+++liftFile ::+ (ChannelMsg.T -> Maybe (Channel, a)) ->+ (FileEvent.T -> Maybe (Channel, a))+liftFile checkMsg msg =+ case msg of+ FileEvent.MIDIEvent midiMsg -> checkMsg midiMsg+ _ -> Nothing++instance C FileEvent.T where+ note = liftFile note+ program = liftFile program+ anyController = liftFile anyController+ pitchBend = liftFile pitchBend+ channelPressure = liftFile channelPressure+ mode = liftFile mode
+ src/Sound/MIDI/Message/Class/Utility.hs view
@@ -0,0 +1,57 @@+module Sound.MIDI.Message.Class.Utility where++import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel.Mode as Mode+import qualified Sound.MIDI.Message.Channel as ChannelMsg+++note :: Maybe ChannelMsg.Body -> Maybe (Velocity, Pitch, Bool)+program :: Maybe ChannelMsg.Body -> Maybe Program+anyController :: Maybe ChannelMsg.Body -> Maybe (Controller, Int)+pitchBend :: Maybe ChannelMsg.Body -> Maybe Int+channelPressure :: Maybe ChannelMsg.Body -> Maybe Int+mode :: Maybe ChannelMsg.Body -> Maybe Mode.T++note msg = do+ ChannelMsg.Voice voice <- msg+ case voice of+ VoiceMsg.NoteOn pitch velocity -> Just (velocity, pitch, True)+ VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False)+ _ -> Nothing++program msg = do+ ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <- msg+ return pgm++anyController msg = do+ ChannelMsg.Voice (VoiceMsg.Control ctrl val) <- msg+ return (ctrl, val)++pitchBend msg = do+ ChannelMsg.Voice (VoiceMsg.PitchBend bend) <- msg+ return bend++channelPressure msg = do+ ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <- msg+ return pressure++mode msg = do+ ChannelMsg.Mode m <- msg+ return m+++explicitNoteOff ::+ (Velocity, Pitch, Bool) -> (Velocity, Pitch, Bool)+explicitNoteOff x@(v,p,b) =+ if b && v == VoiceMsg.toVelocity 0+ then (VoiceMsg.toVelocity 64, p, False)+ else x++implicitNoteOff ::+ (Velocity, Pitch, Bool) -> (Velocity, Pitch, Bool)+implicitNoteOff x@(v,p,b) =+ if not b && v == VoiceMsg.toVelocity 64+ then (VoiceMsg.toVelocity 0, p, True)+ else x
src/Sound/MIDI/Message/System.hs view
@@ -9,7 +9,6 @@ import qualified Sound.MIDI.Message.System.Common as Common import qualified Sound.MIDI.Message.System.RealTime as RealTime --- import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Writer.Basic as Writer@@ -26,7 +25,7 @@ | RealTime RealTime.T -get :: Parser.C parser => Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Parser.Fragile parser T get code = if code == 0xF0 then liftM Exclusive Exclusive.get@@ -38,7 +37,7 @@ then liftM RealTime $ RealTime.get code else Parser.giveUp ("invalid System message code " ++ show code) -getIncomplete :: Parser.C parser => Int -> Parser.Partial (Parser.Fallible parser) T+getIncomplete :: Parser.C parser => Int -> Parser.Partial (Parser.Fragile parser) T getIncomplete code = if code == 0xF0 then liftM (fmap Exclusive) Exclusive.getIncomplete
src/Sound/MIDI/Message/System/Common.hs view
@@ -40,7 +40,7 @@ -- * serialization -get :: Parser.C parser => Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Parser.Fragile parser T get code = case code of 0xF1 ->
src/Sound/MIDI/Message/System/Exclusive.hs view
@@ -14,7 +14,7 @@ import qualified Sound.MIDI.Writer.Basic as Writer import Sound.MIDI.Monoid ((+#+)) -import Control.Monad.Trans.Class (MonadTrans, lift, )+import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Exception.Asynchronous as Async import Data.Maybe (fromMaybe, )@@ -40,15 +40,15 @@ -- * serialization -get :: Parser.C parser => Parser.Fallible parser T+get :: Parser.C parser => Parser.Fragile parser T get = do (Async.Exceptional err sysex) <- getIncomplete maybe (return sysex) Parser.giveUp err -getIncomplete :: Parser.C parser => Parser.Partial (Parser.Fallible parser) T+getIncomplete :: Parser.C parser => Parser.Partial (Parser.Fragile parser) T getIncomplete = do manu <- Manufacturer.get- incBody <- lift getBody+ incBody <- MT.lift getBody return $ flip fmap incBody $ \body -> fromMaybe (Commercial manu body) $ lookup manu $
src/Sound/MIDI/Message/System/RealTime.hs view
@@ -5,7 +5,6 @@ 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@@ -25,7 +24,7 @@ -- * serialization -get :: Parser.C parser => Int -> Parser.Fallible parser T+get :: Parser.C parser => Int -> Parser.Fragile parser T get code = case code of 0xF8 -> return TimingClock
src/Sound/MIDI/Monoid.hs view
@@ -1,7 +1,9 @@ module Sound.MIDI.Monoid where -import Data.Monoid (Monoid, mappend, mconcat, )-import Prelude hiding (concatMap, )+import Data.Foldable (foldMap, )+import Data.Monoid (Monoid, mappend, )+import Data.Semigroup (Semigroup, sconcat, (<>))+import Data.List.NonEmpty (NonEmpty, ) @@ -11,16 +13,17 @@ (+#+) = mappend -genAppend :: (Monoid m) =>+genAppend :: (Semigroup m) => (m -> a) -> (a -> m) -> a -> a -> a genAppend cons decons x y =- cons $ mappend (decons x) (decons y)+ cons $ decons x <> decons y genConcat :: (Monoid m) => (m -> a) -> (a -> m) -> [a] -> a genConcat cons decons =- cons . concatMap decons+ cons . foldMap decons -concatMap :: (Monoid m) =>- (a -> m) -> [a] -> m-concatMap f = mconcat . map f+nonEmptyConcat :: (Semigroup m) =>+ (m -> a) -> (a -> m) -> NonEmpty a -> a+nonEmptyConcat cons decons =+ cons . sconcat . fmap decons
src/Sound/MIDI/Parser/ByteString.hs view
@@ -11,6 +11,8 @@ import Data.Binary.Get (Get, runGet, ) import Control.Monad.Trans.Class (lift, )+import Control.Monad (liftM, ap, )+import Control.Applicative (Applicative, pure, (<*>), ) import qualified Sound.MIDI.Parser.Report as Report @@ -19,10 +21,6 @@ import qualified Sound.MIDI.Parser.Exception as Exception import qualified Sound.MIDI.Parser.Warning as Warning --- import qualified Control.Monad.Exception.Synchronous as Sync---- import Data.Word (Word8)- import Data.Int (Int64) import qualified Numeric.NonNegative.Wrapper as NonNeg @@ -40,7 +38,7 @@ -} -run :: Parser.Fallible T a -> B.ByteString -> Report.T a+run :: Parser.Fragile T a -> B.ByteString -> Report.T a run parser input = flip runGet input $ Warning.run $ decons $ Exception.run $ (do a <- parser@@ -55,7 +53,7 @@ and thus further parsing is not possible. -} runIncomplete ::- Parser.Partial (Parser.Fallible T) a -> B.ByteString -> Report.T a+ Parser.Partial (Parser.Fragile T) a -> B.ByteString -> Report.T a runIncomplete parser input = flip run input $ lift . Parser.warnIncomplete =<< parser@@ -66,8 +64,14 @@ Cons $ lift p +instance Functor T where+ fmap = liftM++instance Applicative T where+ pure = Cons . return+ (<*>) = ap+ instance Monad T where- return = Cons . return x >>= y = Cons $ decons . y =<< decons x
− src/Sound/MIDI/Parser/Class.hs
@@ -1,174 +0,0 @@-module Sound.MIDI.Parser.Class- (EndCheck, isEnd,- C, getByte, skip,- warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,- until, zeroOrMore, zeroOrMoreInc, replicate,- emptyList, PossiblyIncomplete, UserMessage,- Fallible, Partial,- {- for debugging- absorbException, appendIncomplete,- -}- ) where---import Sound.MIDI.Parser.Report (UserMessage)-import qualified Sound.MIDI.Parser.Exception as Exc-import qualified Control.Monad.Exception.Asynchronous as Async-import qualified Control.Monad.Exception.Synchronous as Sync--import Control.Monad.Trans.Class (lift, )-import Control.Monad.Trans.State (StateT, )-import Control.Monad (liftM, liftM2, when, )--import Data.Word (Word8)--import qualified Numeric.NonNegative.Wrapper as NonNeg--import Prelude hiding (replicate, until, )----class Monad parser => EndCheck parser where- isEnd :: parser Bool---- would be probably better placed in Parser.Status-instance EndCheck parser => EndCheck (StateT st parser) where- isEnd = lift $ isEnd---class EndCheck parser => C parser where- getByte :: Fallible parser Word8- skip :: NonNeg.Integer -> Fallible parser ()- warn :: UserMessage -> parser ()---{- |-@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.--}-type PossiblyIncomplete a = Async.Exceptional UserMessage a---type Fallible parser = Sync.ExceptionalT UserMessage parser-type Partial parser a = parser (PossiblyIncomplete a)---warnIf :: C parser => Bool -> UserMessage -> parser ()-warnIf b msg = when b (warn msg)--{- |-Emit a warning if a value is said to be incomplete.-Be careful using this function,-because an incomplete value often means-that subsequent parse actions will process data from the wrong position.-Only use this function if you-either know that the parse is complete also if the parsed value is incomplete-or if there are no subsequent parse actions to run.--This function cannot fail.--}-warnIncomplete :: C parser => PossiblyIncomplete a -> parser a-warnIncomplete ~(Async.Exceptional me a) =- do maybe (return ()) warn me- return a---{- |-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 :: EndCheck parser =>- Fallible parser a -> Partial parser [a]-zeroOrMore p =- let go =- isEnd >>= \b ->- if b- then return emptyList- else absorbException- (liftM2 (\ x -> fmap (x:)) p (lift go))- in go---zeroOrMoreInc :: EndCheck parser =>- Partial (Fallible parser) a -> Partial parser [a]-zeroOrMoreInc p =- let go =- isEnd >>= \b ->- if b- then return emptyList- else absorbException- (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 signaled.--}-until :: EndCheck parser =>- (a -> Bool) -> Fallible parser a -> Partial parser [a]-until c p =- let go =- isEnd >>= \b ->- if b- then- return $ Async.broken- "Parser.until: unexpected end of input" []- else- absorbException $- p >>= \x ->- if c x- then return emptyList- else liftM (fmap (x:)) (lift go)- in go---{- |-This function will never fail.-It may however return a list that is shorter than requested.--}-replicate ::- C parser =>- NonNeg.Int ->- Partial (Fallible parser) a ->- Partial parser [a]-replicate m p =- let go n =- if n==0- then return emptyList- else absorbException- (appendIncomplete p (go (n-1)))- in go m---emptyList :: PossiblyIncomplete [a]-emptyList = Async.pure []--{- |-The first parser may fail, but the second one must not.--}-appendIncomplete ::- Monad parser =>- Partial (Fallible parser) a ->- Partial parser [a] ->- Partial (Fallible parser) [a]-appendIncomplete p ps =- do ~(Async.Exceptional me x) <- p- lift $ liftM (fmap (x:)) $- maybe ps (\_ -> return (Async.Exceptional me [])) me--absorbException ::- Monad parser =>- Partial (Fallible parser) [a] ->- Partial parser [a]-absorbException =- Sync.resolveT (\errMsg -> return $ Async.broken errMsg [])
− src/Sound/MIDI/Parser/Exception.hs
@@ -1,24 +0,0 @@-{- |-Handling of exceptions.--}-module Sound.MIDI.Parser.Exception where--import qualified Sound.MIDI.Parser.Report as Report--- import qualified Sound.MIDI.Parser.Warning as Warning--import qualified Control.Monad.Exception.Synchronous as Sync---type T m = Sync.ExceptionalT Report.UserMessage m---run :: Monad m =>- T m a -> m (Sync.Exceptional Report.UserMessage a)-run = Sync.runExceptionalT---giveUp :: Monad m => String -> T m a-giveUp = Sync.throwT--try :: Monad m => T m a -> m (Sync.Exceptional Report.UserMessage a)-try = Sync.tryT
src/Sound/MIDI/Parser/File.hs view
@@ -7,7 +7,8 @@ import Control.Monad.Trans.Reader (ReaderT(runReaderT), ask, ) import Control.Monad.Trans.Class (lift, )-import Control.Monad (liftM, )+import Control.Monad (liftM, ap, )+import Control.Applicative (Applicative, pure, (<*>), ) import qualified System.IO.Error as IOE import qualified Control.Exception as Exc@@ -24,14 +25,14 @@ newtype T a = Cons {decons :: ReaderT IO.Handle IO a} -runFile :: Parser.Fallible T a -> FilePath -> IO a+runFile :: Parser.Fragile T a -> FilePath -> IO a runFile p name = Exc.bracket (IO.openBinaryFile name IO.ReadMode) IO.hClose (runHandle p) -runHandle :: Parser.Fallible T a -> IO.Handle -> IO a+runHandle :: Parser.Fragile T a -> IO.Handle -> IO a runHandle p h = do exc <- runReaderT (decons (Sync.tryT p)) h Sync.resolve (IOE.ioError . IOE.userError) (fmap return exc)@@ -43,7 +44,7 @@ we cannot know where the current file position is, we omit the @runIncompleteHandle@ variant. -}-runIncompleteFile :: Parser.Partial (Parser.Fallible T) a -> FilePath -> IO a+runIncompleteFile :: Parser.Partial (Parser.Fragile T) a -> FilePath -> IO a runIncompleteFile p name = Exc.bracket (IO.openBinaryFile name IO.ReadMode)@@ -56,23 +57,32 @@ +instance Functor T where+ fmap = liftM++instance Applicative T where+ pure = Cons . return+ (<*>) = ap+ 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 -fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a-fallibleFromIO act =+ioeTry :: IO a -> IO (Either IOError a)+ioeTry = Exc.try++fragileFromIO :: (IO.Handle -> IO a) -> Parser.Fragile T a+fragileFromIO act = Sync.ExceptionalT . Cons . lift .- fmap (Sync.mapException show . Sync.fromEither) . IOE.try . act+ fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act =<< lift (Cons ask) instance Parser.EndCheck T where isEnd = fromIO IO.hIsEOF instance Parser.C T where- getByte = fallibleFromIO $ liftM (fromIntegral . ord) . IO.hGetChar- skip n = fallibleFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)+ getByte = fragileFromIO $ liftM (fromIntegral . ord) . IO.hGetChar+ skip n = fragileFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n) warn = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg))
src/Sound/MIDI/Parser/Primitive.hs view
@@ -23,20 +23,20 @@ {- | 'getByte' gets a single byte from the input. -}-getByte :: Parser.C parser => Parser.Fallible parser Word8+getByte :: Parser.C parser => Parser.Fragile parser Word8 getByte = Parser.getByte {- | @getN n@ returns n characters (bytes) from the input. -}-getN :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser ByteList+getN :: Parser.C parser => NonNeg.Int -> Parser.Fragile parser ByteList getN n = replicateM (NonNeg.toNumber n) getByte -getString :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser String+getString :: Parser.C parser => NonNeg.Integer -> Parser.Fragile parser String getString n = liftM listCharFromByte (getBigN n) -getBigN :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser ByteList+getBigN :: Parser.C parser => NonNeg.Integer -> Parser.Fragile parser ByteList getBigN n = sequence $ Bit.replicateBig@@ -50,22 +50,22 @@ 4-byte numbers from the input (respectively), convert the base-256 data into a single number, and return. -}-get1 :: Parser.C parser => Parser.Fallible parser Int+get1 :: Parser.C parser => Parser.Fragile parser Int get1 = liftM fromIntegral getByte -getNByteInt :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser Int+getNByteInt :: Parser.C parser => NonNeg.Int -> Parser.Fragile parser Int getNByteInt n = liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1) -get2, get3, get4 :: Parser.C parser => Parser.Fallible parser Int+get2, get3, get4 :: Parser.C parser => Parser.Fragile parser Int get2 = getNByteInt 2 get3 = getNByteInt 3 get4 = getNByteInt 4 -getByteAsCardinal :: Parser.C parser => Parser.Fallible parser NonNeg.Integer+getByteAsCardinal :: Parser.C parser => Parser.Fragile parser NonNeg.Integer getByteAsCardinal = liftM fromIntegral getByte -getNByteCardinal :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser NonNeg.Integer+getNByteCardinal :: Parser.C parser => NonNeg.Int -> Parser.Fragile parser NonNeg.Integer getNByteCardinal n = liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) getByteAsCardinal) @@ -78,7 +78,7 @@ If it's @0@, that byte is the last one. 'getVar' gets a variable-length quantity from the input. -}-getVar :: Parser.C parser => Parser.Fallible parser NonNeg.Integer+getVar :: Parser.C parser => Parser.Fragile parser NonNeg.Integer getVar = liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes @@ -86,7 +86,7 @@ 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.Fallible parser [Word8]+getVarBytes :: Parser.C parser => Parser.Fragile parser [Word8] getVarBytes = do digit <- getByte@@ -95,12 +95,12 @@ else return [digit] -getEnum :: (Parser.C parser, Enum enum, Bounded enum) => Parser.Fallible parser enum+getEnum :: (Parser.C parser, Enum enum, Bounded enum) => Parser.Fragile parser enum getEnum = makeEnum =<< get1 -makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> Parser.Fallible parser enum+makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> Parser.Fragile parser enum makeEnum n =- let go :: (Parser.C parser, Enum a) => a -> a -> Parser.Fallible parser a+ let go :: (Parser.C parser, Enum a) => a -> a -> Parser.Fragile parser a go lower upper = if fromEnum lower <= n && n <= fromEnum upper then return (toEnum n)
src/Sound/MIDI/Parser/Restricted.hs view
@@ -4,7 +4,7 @@ where the length of a part is fixed by a length specification. -} module Sound.MIDI.Parser.Restricted- (T(..), run, runFallible, ) where+ (T(..), run, runFragile, ) where import qualified Sound.MIDI.Parser.Class as Parser @@ -12,6 +12,7 @@ import qualified Control.Monad.Trans.Class as Trans import Control.Monad.Trans.State (StateT(runStateT), gets, get, put, ) import Control.Monad (when, )+import Control.Applicative (Applicative, pure, (<*>), ) import qualified Numeric.NonNegative.Wrapper as NonNeg @@ -27,12 +28,12 @@ ("unparsed bytes left in part (" ++ show remaining ++ " bytes)") return x -runFallible :: Parser.C parser =>- NonNeg.Integer -> Parser.Fallible (T parser) a -> Parser.Fallible parser a-runFallible len = Sync.mapExceptionalT (run len)+runFragile :: Parser.C parser =>+ NonNeg.Integer -> Parser.Fragile (T parser) a -> Parser.Fragile parser a+runFragile len = Sync.mapExceptionalT (run len) -lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a+lift :: Monad parser => Parser.Fragile parser a -> Parser.Fragile (T parser) a lift = Sync.mapExceptionalT Trans.lift @@ -40,18 +41,24 @@ newtype T parser a = Cons {decons :: StateT NonNeg.Integer parser a} +instance Functor parser => Functor (T parser) where+ fmap f = Cons . fmap f . decons++instance (Applicative parser, Monad parser) => Applicative (T parser) where+ pure = Cons . pure+ Cons f <*> Cons a = Cons $ f <*> a+ instance Monad parser => Monad (T parser) where- return = Cons . return x >>= y = Cons $ decons . y =<< decons x instance Trans.MonadTrans T where lift = Cons . Trans.lift -getRemaining :: Monad parser => Parser.Fallible (T parser) NonNeg.Integer+getRemaining :: Monad parser => Parser.Fragile (T parser) NonNeg.Integer getRemaining = Trans.lift $ Cons get -putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fallible (T parser) ()+putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fragile (T parser) () putRemaining = Trans.lift . Cons . put
src/Sound/MIDI/Parser/Status.hs view
@@ -5,15 +5,19 @@ -} module Sound.MIDI.Parser.Status (T, Status, set, get, run, lift,- Channel, fromChannel, toChannel, ) where+ Channel, fromChannel, toChannel, ) where import qualified Sound.MIDI.Parser.Class as Parser import qualified Control.Monad.Exception.Synchronous as Sync-import Control.Monad.Trans.State (StateT, evalStateT, ) import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Class as Trans+import Control.Monad.Trans.State (StateT, evalStateT, )+import Control.Monad (liftM, ) +import qualified Test.QuickCheck as QC+import Test.QuickCheck (Arbitrary(arbitrary, shrink), )+ import Sound.MIDI.Utility (checkRange, ) import Data.Ix (Ix) @@ -32,17 +36,17 @@ type Status = Maybe (Int,Channel) -set :: Monad parser => Status -> Parser.Fallible (T parser) ()+set :: Monad parser => Status -> Parser.Fragile (T parser) () set = Trans.lift . State.put -get :: Monad parser => Parser.Fallible (T parser) Status+get :: Monad parser => Parser.Fragile (T parser) Status get = Trans.lift State.get run :: Monad parser => T parser a -> parser a run = flip evalStateT Nothing -lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a+lift :: Monad parser => Parser.Fragile parser a -> Parser.Fragile (T parser) a lift = Sync.mapExceptionalT Trans.lift @@ -52,7 +56,7 @@ This definition should be in Message.Channel, but this results in a cyclic import. -}-newtype Channel = Channel {fromChannel :: Int} deriving (Show, Eq, Ord, Ix)+newtype Channel = Channel {fromChannel :: Int} deriving (Show, Eq, Ord, Ix) toChannel :: Int -> Channel toChannel = checkRange "Channel" Channel@@ -64,3 +68,7 @@ instance Bounded Channel where minBound = Channel 0 maxBound = Channel 15++instance Arbitrary Channel where+ arbitrary = liftM toChannel $ QC.choose (0,15)+ shrink = map (toChannel . flip mod 16) . shrink . fromChannel
− src/Sound/MIDI/Parser/Stream.hs
@@ -1,130 +0,0 @@-module Sound.MIDI.Parser.Stream- (T(..), run, runIncomplete, runPartial,- ByteList(..),- PossiblyIncomplete, UserMessage, ) where---import Control.Monad.Trans.State- (State, runState, evalState, get, put, )-import Control.Monad.Trans.Class (lift, )-import Control.Monad (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.Parser.Exception as Exception-import qualified Sound.MIDI.Parser.Warning as Warning---- import qualified Control.Monad.Exception.Synchronous as Sync--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 :: Warning.T (State str) a}----runPartial :: Parser.Fallible (T str) a -> str -> (Report.T a, str)-runPartial parser input =- flip runState input $ Warning.run $ decons $ Exception.run parser--run :: ByteStream str => Parser.Fallible (T str) a -> str -> Report.T a-run parser input =- flip evalState input $ Warning.run $ decons $ Exception.run $- (do a <- parser- lift $- Parser.isEnd >>= \end ->- Parser.warnIf (not end) "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 =>- Parser.Partial (Parser.Fallible (T str)) a -> str -> Report.T a-runIncomplete parser input =- flip run input $- lift . Parser.warnIncomplete =<< parser----fromState :: State str a -> T str a-fromState p =- Cons $ lift p---instance Monad (T str) where- return = Cons . return- x >>= y = Cons $ decons . y =<< decons x---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.EndCheck (T str) where- isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get--instance ByteStream str => Parser.C (T str) where- getByte =- switchL- (Parser.giveUp "unexpected end of data")- (\s ss -> lift (fromState (put ss)) >> return s) =<<- lift (fromState get)--{-- skip n = sequence_ (genericReplicate n Parser.getByte)--}- skip n = when (n>0) $- do s <- lift $ fromState get- switchL- (Parser.giveUp "skip past end of part")- (\ _ rest -> lift $ fromState $ put rest)- (drop (n-1) s)-- warn = Cons . Warning.warn---{--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/Parser/Warning.hs
@@ -1,28 +0,0 @@-{- |-Handling of warnings.--}-module Sound.MIDI.Parser.Warning where--import qualified Sound.MIDI.Parser.Report as Report--import qualified Control.Monad.Exception.Synchronous as Sync-import qualified Control.Monad.Trans.Writer as Writer---type T m = Writer.WriterT [Report.UserMessage] m---run :: Monad m =>- T m (Sync.Exceptional Report.UserMessage a) -> m (Report.T a)-run act =- do (exc,warns) <- Writer.runWriterT act- return $ Report.Cons warns (Sync.toEither exc)--{--run :: Monad m =>- T m a -> m (a, [Report.UserMessage])-run = Writer.runWriterT--}--warn :: Monad m => String -> T m ()-warn text = Writer.tell [text]
src/Sound/MIDI/Utility.hs view
@@ -2,39 +2,10 @@ 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)--{-# INLINE mapSnd #-}-mapSnd :: (b -> d) -> (a,b) -> (a,d)-mapSnd g ~(x,y) = (x, g y)+import Data.Tuple.HT (mapFst, )+import Data.Word (Word8, ) -{-# INLINE fst3 #-}-fst3 :: (a,b,c) -> a-fst3 (x,_,_) = x--{-# INLINE snd3 #-}-snd3 :: (a,b,c) -> b-snd3 (_,x,_) = x--{-# INLINE thd3 #-}-thd3 :: (a,b,c) -> c-thd3 (_,_,x) = x--{-# INLINE toMaybe #-}-toMaybe :: Bool -> a -> Maybe a-toMaybe False _ = Nothing-toMaybe True x = Just x--{-# 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@@ -44,28 +15,6 @@ 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
src/Sound/MIDI/Writer/Basic.hs view
@@ -4,13 +4,14 @@ import qualified Sound.MIDI.Bit as Bit import qualified Sound.MIDI.IO as MIO-import qualified Sound.MIDI.Monoid as M import qualified Data.Monoid as Monoid import Data.Bits ((.|.)) import Sound.MIDI.IO (listByteFromChar, )-import Data.Monoid (Monoid, mempty, mappend, mconcat, )-import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, )+import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, nonEmptyConcat, )+import Data.Foldable (foldMap, )+import Data.Monoid (Monoid, mempty, mconcat, )+import Data.Semigroup (Semigroup(sconcat, (<>)), ) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, ) import Control.Monad.Trans.Class (lift, )@@ -26,7 +27,6 @@ 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, ) @@ -43,19 +43,21 @@ -- differences list-newtype ByteList =- ByteList {unByteList :: Monoid.Endo MIO.ByteList}+newtype ByteList = ByteList {unByteList :: Monoid.Endo MIO.ByteList} +instance Semigroup ByteList where+ (<>) = genAppend ByteList unByteList+ sconcat = nonEmptyConcat ByteList unByteList+ instance Monoid ByteList where mempty = ByteList mempty- mappend = genAppend ByteList unByteList mconcat = genConcat ByteList unByteList instance C ByteList where putByte = ByteList . Monoid.Endo . (:) putLengthBlock n writeBody = let body = runByteList writeBody- in putInt n (length body) `mappend`+ in putInt n (length body) <> putByteListSpec body -- we could call 'writeBody' but this would recompute the data @@ -70,12 +72,14 @@ -newtype ByteString =- ByteString {unByteString :: Builder}+newtype ByteString = ByteString {unByteString :: Builder} +instance Semigroup ByteString where+ (<>) = genAppend ByteString unByteString+ sconcat = nonEmptyConcat ByteString unByteString+ instance Monoid ByteString where mempty = ByteString $ mempty- mappend = genAppend ByteString unByteString mconcat = genConcat ByteString unByteString instance C ByteString where@@ -96,13 +100,14 @@ -newtype SeekableFile =- SeekableFile {unSeekableFile :: ReaderT Handle IO ()}+newtype SeekableFile = SeekableFile {unSeekableFile :: ReaderT Handle IO ()} +instance Semigroup SeekableFile where+ x <> y = SeekableFile $ unSeekableFile x >> unSeekableFile y+ instance Monoid SeekableFile where mempty = SeekableFile $ return ()- mappend x y = SeekableFile $ unSeekableFile x >> unSeekableFile y- mconcat xs = SeekableFile $ mapM_ unSeekableFile xs+ mconcat = SeekableFile . mapM_ unSeekableFile instance C SeekableFile where putByte c =@@ -150,7 +155,7 @@ putIntAsByte x = putByte $ fromIntegral x putByteList :: C writer => MIO.ByteList -> writer-putByteList = M.concatMap putByte+putByteList = foldMap putByte putLenByteList :: C writer => MIO.ByteList -> writer putLenByteList bytes =
src/Sound/MIDI/Writer/Status.hs view
@@ -3,62 +3,74 @@ lift, ) where --- import qualified Sound.MIDI.Writer.Basic as Writer- import Sound.MIDI.Parser.Status (Channel) import qualified Data.Monoid.State as State-import qualified Data.Monoid.Reader as Reader import qualified Data.Monoid.Transformer as Trans import Data.Monoid.Transformer (lift, ) -import Data.Monoid (Monoid, mempty, mappend, mconcat, )-import Sound.MIDI.Monoid (genAppend, genConcat, )+import qualified Data.Monoid.HT as MonoidHT+import Data.Monoid (Monoid, mempty, mconcat, )+import Data.Semigroup (Semigroup, sconcat, (<>), )+import Sound.MIDI.Monoid (genAppend, genConcat, nonEmptyConcat, ) +data Uncompressed = Uncompressed++newtype Compressed = Compressed Status type Status = Maybe (Int,Channel) {- |-The ReaderT Bool handles-whether running status should be respected (True) or ignored (False).+'status' can be 'Uncompressed' for files ignoring the running status+or 'Compressed' for files respecting the running status. -}-newtype T writer =- Cons {decons :: Reader.T Bool (State.T (Maybe Status) writer)}+newtype T compress writer = Cons {decons :: State.T compress writer} -instance Monoid writer => Monoid (T writer) where+instance Semigroup writer => Semigroup (T compress writer) where+ (<>) = genAppend Cons decons+ sconcat = nonEmptyConcat Cons decons++instance Monoid writer => Monoid (T compress writer) where mempty = Cons $ mempty- mappend = genAppend Cons decons mconcat = genConcat Cons decons -{- |-Given a writer that emits a status, generate a stateful writer,-that decides whether to run the status emittor.--}-change :: (Monoid writer) => Status -> writer -> T writer-change x emit =- Cons $- Reader.Cons $ \b ->- State.Cons $ \my ->- let mx = Just x- in (if not b || mx/=my then emit else mempty, mx) -clear :: (Monoid writer) => T writer-clear = Cons $ lift $ State.put Nothing+class Compression compress where+ {- |+ Given a writer that emits a status, generate a stateful writer,+ that decides whether to run the status emittor.+ -}+ change :: (Monoid writer) => (Int, Channel) -> writer -> T compress writer+ initState :: compress +instance Compression Uncompressed where+ change _ emit = Cons $ State.pure emit+ initState = Uncompressed -instance Trans.C T where+instance Compression Compressed where+ change x emit =+ Cons $+ State.Cons $ \(Compressed my) ->+ let mx = Just x+ in (MonoidHT.when (mx/=my) emit, Compressed mx)+ initState = Compressed Nothing++clear :: (Compression compress, Monoid writer) => T compress writer+clear = Cons $ State.put initState+++instance Trans.C (T compress) where lift = fromWriter -fromWriter :: (Monoid writer) => writer -> T writer-fromWriter = Cons . lift . lift+fromWriter :: (Monoid writer) => writer -> T compress writer+fromWriter = Cons . lift -toWriter :: (Monoid writer) => Bool -> T writer -> writer-toWriter withStatus =- State.evaluate Nothing . flip Reader.run withStatus . decons+toWriter :: (Compression compress, Monoid writer) => T compress writer -> writer+toWriter = State.evaluate initState . decons -toWriterWithStatus :: (Monoid writer) => T writer -> writer-toWriterWithStatus = toWriter True+toWriterWithStatus :: (Monoid writer) => T Compressed writer -> writer+toWriterWithStatus = toWriter -toWriterWithoutStatus :: (Monoid writer) => T writer -> writer-toWriterWithoutStatus = toWriter False+toWriterWithoutStatus :: (Monoid writer) => T Uncompressed writer -> writer+toWriterWithoutStatus = toWriter
+ test/Common.hs view
@@ -0,0 +1,6 @@+module Common where++import qualified Test.QuickCheck as QC++check :: QC.Testable prop => String -> prop -> IO ()+check msg t = putStr (msg ++ ": ") >> QC.quickCheck t
+ test/Example.hs view
@@ -0,0 +1,45 @@+module Example where++import qualified Sound.MIDI.File.Event.Meta as MetaEvent+import qualified Sound.MIDI.File.Event as Event+import qualified Sound.MIDI.File as MidiFile++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg++import qualified Data.EventList.Relative.TimeBody as EventList+import Data.EventList.Relative.MixedBody ((/.), (./), )+++empty :: MidiFile.T+empty =+ MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)+ [EventList.empty]++meta :: MidiFile.T+meta =+ MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)+ [EventList.singleton 0 (Event.MetaEvent (MetaEvent.Lyric "foobarz"))]++status :: MidiFile.T+status =+ 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]+++readAfterEnd :: MidiFile.T+readAfterEnd =+ let chan = ChannelMsg.toChannel 3+ vel = VoiceMsg.toVelocity 64+ pit = VoiceMsg.toPitch 22+ in MidiFile.Cons MidiFile.Mixed (MidiFile.Ticks 10)+ [0 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff pit vel))) ./+ EventList.empty]
test/Main.hs view
@@ -1,72 +1,40 @@ {- ToDo: -check whether load of randomly corrupted files yields Parser errors rather than 'undefined'.--Check parsing and serialization of MIDI messages.+Check parsing and serialization of single MIDI messages. -} module Main where +import qualified Example+import qualified Parser++import qualified Test.QuickCheck as QC+import Common (check, )+ 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.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.Trans.Class (lift, )-import Control.Monad (when, )--import System.Random (mkStdGen, randomR, )--import qualified Numeric.NonNegative.Wrapper as NonNeg--import Test.QuickCheck (quickCheck, )+import qualified Data.List.HT as ListHT+import qualified Data.List.Match as Match+import Data.Int (Int64, )+import Data.Ord.HT (comparing, ) --- import Debug.Trace (trace)+import Control.Monad (liftM, when, ) 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@@ -80,9 +48,28 @@ -- 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+ all ((< 10) . length . EventList.toPairList) tracks +{- |+Increase the probability of similar adjacent messages+that can be compressed using the running status.+-}+newtype SortedFile = SortedFile {getSortedFile :: MidiFile.T}+ deriving Show++sortedFile :: MidiFile.T -> SortedFile+sortedFile =+ SortedFile .+ MidiFile.mapTrack+ (EventList.fromPairList .+ List.sortBy (comparing snd) . EventList.toPairList)++instance QC.Arbitrary SortedFile where+ arbitrary = liftM sortedFile QC.arbitrary+ shrink = map sortedFile . QC.shrink . getSortedFile++ saveLoadByteString :: MidiFile.T -> Bool saveLoadByteString midi = let bin = Save.toByteString midi@@ -97,6 +84,48 @@ report = Report.Cons [] (Right (MidiFile.implicitNoteOff midi)) in struct == report +compressionShortens :: MidiFile.T -> Bool+compressionShortens midi =+ B.length (Save.toByteString midi)+ >=+ B.length (Save.toCompressedByteString midi)+++{-+This does not cover all cases of possible running status compression,+but the most common ones.+-}+equalStatus :: Event.T -> Event.T -> Bool+equalStatus x y =+ case (Event.maybeVoice x, Event.maybeVoice y) of+ (Just (ch0, ev0), Just (ch1, ev1)) ->+ ch0 == ch1+ &&+ case (ev0, ev1) of+ (VoiceMsg.Control _ _, VoiceMsg.Control _ _) -> True+ _ ->+ VoiceMsg.isNoteOn ev0 && VoiceMsg.isNoteOn ev1+ ||+ VoiceMsg.isNoteOff ev0 && VoiceMsg.isNoteOff ev1+ _ -> False++{-+You may test manually with Example.status+which is definitely compressible.+-}+compressible :: MidiFile.T -> Bool+compressible =+ any (or . ListHT.mapAdjacent equalStatus . EventList.getBodies) .+ MidiFile.getTracks . MidiFile.implicitNoteOff++compressionStrictlyShortens :: MidiFile.T -> QC.Property+compressionStrictlyShortens midi =+ compressible midi+ QC.==>+ B.length (Save.toByteString midi)+ >+ B.length (Save.toCompressedByteString midi)+ saveLoadMaybeByteList :: MidiFile.T -> Bool saveLoadMaybeByteList midi = let bin = Save.toByteList midi@@ -129,7 +158,7 @@ let bin0 = Save.toCompressedByteString midi0 in case Load.maybeFromByteString bin0 of Report.Cons [] (Right midi1) ->- bin0 == Save.toByteString midi1+ bin0 == Save.toCompressedByteString midi1 _ -> False loadSaveByteList :: MidiFile.T -> Bool@@ -148,14 +177,6 @@ Load.fromByteList (bin++[undefined]) -lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool-lazinessZeroOrMoreByteList pos byte =- let result =- Report.result $ StreamParser.runIncomplete (lift (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@@ -165,10 +186,10 @@ -} bin1 = init bin0 ++ [undefined] (MidiFile.Cons _ _ tracks1) = Load.fromByteList bin1- in case viewR tracks0 of+ in case ListHT.viewR tracks0 of Just (initTracks0, lastTrack0) -> List.isPrefixOf initTracks0 tracks1 &&- let (lastTrack1:_) = dropMatch initTracks0 tracks1+ let (lastTrack1:_) = Match.drop initTracks0 tracks1 in List.isPrefixOf (init (EventList.toPairList lastTrack0)) (EventList.toPairList lastTrack1)@@ -181,13 +202,16 @@ {- | Check whether corruptions in a file are properly detected-and do not trap into an errors.+and do not trap into errors.++Sometimes it may yield an error which is @binary@'s fault.+See 'readAfterEnd'. -}-corruptionByteString :: Int -> Int -> MidiFile.T -> Bool-corruptionByteString seed replacement midi =+corruptionByteString :: Int64 -> Int -> MidiFile.T -> Bool+corruptionByteString pos 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+ n = mod pos (B.length bin + 1)+ (pre, post) = B.splitAt n bin replaceByte = fromIntegral replacement corruptBin = B.append pre@@ -199,9 +223,9 @@ Report.Cons _ _ -> True corruptionByteList :: Int -> Int -> MidiFile.T -> Bool-corruptionByteList seed replacement midi =+corruptionByteList pos replacement midi = let bin = Save.toByteList midi- n = fst $ randomR (0, length bin) (mkStdGen seed)+ n = mod pos (length bin + 1) (pre, post) = splitAt n bin corruptBin = pre ++ fromIntegral replacement :@@ -209,29 +233,57 @@ in case Load.maybeFromByteList corruptBin of Report.Cons _ _ -> True +{- |+This demonstrates a problem of the @binary@ package.+If the binary @Get@ parser reads past the end of the file,+then @runGet@ yields an error not a parser failure.+This example provokes the problem by setting the @MTrk@ length to 0,+which makes the following data look like an alien chunk with large size.+When skipping following data of this size, 'runGet' yields an 'error'.+-}+readAfterEnd :: IO ()+readAfterEnd = do+ let bin = Save.toByteString $ Example.readAfterEnd+ fails =+ filter+ (\pos -> not $ corruptionByteString pos 0 Example.readAfterEnd)+ [0 .. B.length bin]+ when (not $ null fails) $+ putStr $ " fails at positions " ++ show fails+ putStrLn "" + 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+main = do+ runExample Example.empty+ runExample Example.meta+ runExample Example.status+ saveLoadFile Example.status >>= print+ check "saveLoadByteString" saveLoadByteString+ check "saveLoadCompressedByteString" saveLoadCompressedByteString+ check "saveLoadCompressedByteString sorted"+ (saveLoadCompressedByteString . getSortedFile)+ check "saveLoadMaybeByteList" saveLoadMaybeByteList+ check "saveLoadByteList" saveLoadByteList+-- check "saveLoadFile" saveLoadFile+ check "loadSaveByteString" loadSaveByteString+ check "loadSaveCompressedByteString" loadSaveCompressedByteString+ check "loadSaveCompressedByteString sorted"+ (loadSaveCompressedByteString . getSortedFile)+ check "loadSaveByteList" loadSaveByteList - quickCheck restrictionByteList+ check "compressionShortens" compressionShortens+ check "compressionStrictlyShortens"+ (compressionStrictlyShortens . getSortedFile) - quickCheck lazinessZeroOrMoreByteList- quickCheck lazinessByteList+ check "restrictionByteList" restrictionByteList - quickCheck corruptionByteList- quickCheck corruptionByteString+ check "lazinessZeroOrMoreByteList" Parser.lazinessZeroOrMoreByteList+ check "lazinessByteList" lazinessByteList++ check "corruptionByteList" corruptionByteList+ check "corruptionByteString" corruptionByteString+ when False $ putStr "readAfterEnd" >> readAfterEnd {- laziness test:
+ test/Parser.hs view
@@ -0,0 +1,19 @@+module Parser where++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 Control.Monad.Trans.Class (lift, )++import qualified Numeric.NonNegative.Wrapper as NonNeg+++lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool+lazinessZeroOrMoreByteList pos byte =+ let result =+ Report.result $+ StreamParser.runIncomplete (lift (Parser.zeroOrMore Parser.getByte)) $+ StreamParser.ByteList $ repeat $ fromIntegral byte+ char = show result !! mod (NonNeg.toNumber pos) 1000+ in char == char