packages feed

midi 0.2.1.5 → 0.2.2

raw patch · 14 files changed

+246/−136 lines, 14 filesdep ~utility-ht

Dependency ranges changed: utility-ht

Files

midi.cabal view
@@ -1,5 +1,5 @@ Name:             midi-Version:          0.2.1.5+Version:          0.2.2 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -30,7 +30,7 @@ Source-Repository this   type:     darcs   location: http://hub.darcs.net/thielema/midi/-  tag:      0.2.1.5+  tag:      0.2.2  Flag splitBase   description: Choose the new smaller, split-up base package.@@ -39,7 +39,7 @@   Build-Depends:     event-list >=0.0.9 && < 0.2,     non-negative >=0.0.1 && <0.2,-    utility-ht >=0.0.8 && <0.1,+    utility-ht >=0.0.10 && <0.1,     explicit-exception >=0.1 && <0.2,     bytestring >=0.9.0.1 && <0.11,     binary >=0.4.2 && <0.8,
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
src/Sound/MIDI/File/Event.hs view
@@ -109,7 +109,9 @@ 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 -> ChannelMsg.putWithStatus m
src/Sound/MIDI/File/Save.hs view
@@ -22,7 +22,6 @@ 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 Sound.MIDI.IO (ByteList, writeBinaryFile, )@@ -81,7 +80,9 @@   -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)@@ -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/Message.hs view
@@ -73,7 +73,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
@@ -60,12 +60,10 @@             ( 1, liftM Mode  arbitrary) :             [])    shrink (Cons chan body) =-      map (\(c, b) -> Cons (toChannel (mod c 16)) b) $-      case fromChannel chan of-         c ->-            case body of-               Voice v -> map (mapSnd Voice) $ shrink (c, v)-               Mode  m -> map (mapSnd Mode)  $ shrink (c, m)+      map (uncurry Cons) $+      case body of+         Voice v -> map (mapSnd Voice) $ shrink (chan, v)+         Mode  m -> map (mapSnd Mode)  $ shrink (chan, m)   -- * serialization@@ -116,14 +114,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 (code, chan) $       Writer.putIntAsByte (16*code + fromChannel chan)
src/Sound/MIDI/Message/Channel/Voice.hs view
@@ -426,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,13 +1,20 @@-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, )@@ -74,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 ::@@ -129,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
@@ -5,6 +5,7 @@ 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@@ -93,3 +94,18 @@    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
@@ -1,13 +1,19 @@-module Sound.MIDI.Message.Class.Query where+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.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode  import Data.Tuple.HT (mapSnd, )@@ -44,40 +50,20 @@    mode _ev = Nothing  -instance C ChannelMsg.T where-   note msg = do-      ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg-      fmap ((,) (ChannelMsg.messageChannel msg)) $ -         case voice of-            VoiceMsg.NoteOn  pitch velocity -> Just (velocity, pitch, True)-            VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False)-            _ -> Nothing--   program msg = do-      ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <--         Just $ ChannelMsg.messageBody msg-      return (ChannelMsg.messageChannel msg, pgm)--   anyController msg = do-      ChannelMsg.Voice (VoiceMsg.Control ctrl val) <--         Just $ ChannelMsg.messageBody msg-      return (ChannelMsg.messageChannel msg, (ctrl, val))--   pitchBend msg = do-      ChannelMsg.Voice (VoiceMsg.PitchBend bend) <--         Just $ ChannelMsg.messageBody msg-      return (ChannelMsg.messageChannel msg, bend)--   channelPressure msg = do-      ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <--         Just $ ChannelMsg.messageBody msg-      return (ChannelMsg.messageChannel msg, pressure)--   mode msg = do-      ChannelMsg.Mode m <--         Just $ ChannelMsg.messageBody msg-      return (ChannelMsg.messageChannel msg, m)+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@.@@ -115,3 +101,20 @@    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
@@ -1,8 +1,45 @@ module Sound.MIDI.Message.Class.Utility where -import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, )+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 ::
src/Sound/MIDI/Parser/Status.hs view
@@ -10,10 +10,14 @@ 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) @@ -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/Writer/Status.hs view
@@ -6,57 +6,67 @@ 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 qualified Data.Monoid.HT as MonoidHT import Data.Monoid (Monoid, mempty, mappend, mconcat, ) import Sound.MIDI.Monoid (genAppend, genConcat, )  +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 Status writer)}+newtype T compress writer = Cons {decons :: State.T compress writer}  -instance Monoid writer => Monoid (T writer) where+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) => (Int,Channel) -> 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/Main.hs view
@@ -5,10 +5,12 @@ -} module Main where -import Common (check, ) 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@@ -24,9 +26,9 @@ import qualified Data.List.HT as ListHT import qualified Data.List.Match as Match import Data.Int (Int64, )-import Data.Bool.HT (implies, )+import Data.Ord.HT (comparing, ) -import Control.Monad (when, )+import Control.Monad (liftM, when, )   @@ -49,6 +51,25 @@    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,10 +118,10 @@    any (or . ListHT.mapAdjacent equalStatus . EventList.getBodies) .    MidiFile.getTracks -compressionStrictlyShortens :: MidiFile.T -> Bool+compressionStrictlyShortens :: MidiFile.T -> QC.Property compressionStrictlyShortens midi =    compressible midi-   `implies`+   QC.==>    B.length (Save.toByteString midi)    >    B.length (Save.toCompressedByteString midi)@@ -240,15 +261,20 @@    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     check "compressionShortens" compressionShortens-   check "compressionStrictlyShortens" compressionStrictlyShortens+   check "compressionStrictlyShortens"+      (compressionStrictlyShortens . getSortedFile)     check "restrictionByteList" restrictionByteList