packages feed

midi 0.2.0.1 → 0.2.1

raw patch · 18 files changed

+413/−80 lines, 18 filesdep +utility-htdep ~QuickCheck

Dependencies added: utility-ht

Dependency ranges changed: QuickCheck

Files

midi.cabal view
@@ -1,5 +1,5 @@ Name:             midi-Version:          0.2.0.1+Version:          0.2.1 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -7,7 +7,7 @@ Homepage:         http://www.haskell.org/haskellwiki/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+Tested-With:      GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.6.1 Cabal-Version:    >=1.6 Build-Type:       Simple Synopsis:         Handling of MIDI messages and files@@ -30,7 +30,7 @@ Source-Repository this   type:     darcs   location: http://code.haskell.org/~thielema/midi/-  tag:      0.2.0.1+  tag:      0.2.1  Flag splitBase   description: Choose the new smaller, split-up base package.@@ -42,20 +42,21 @@ Library   Build-Depends:     event-list >=0.0.9 && < 0.2,-    non-negative>=0.0.1 && <0.2,+    non-negative >=0.0.1 && <0.2,+    utility-ht >=0.0.8 && <0.1,     explicit-exception >=0.1 && <0.2,     bytestring >=0.9.0.1 && <0.11,     binary >=0.4.2 && <0.6,     transformers >=0.2 && <0.4,     monoid-transformer >=0.0.1 && <0.1,-    QuickCheck >=1 && <3+    QuickCheck >=2.1 && <3   If flag(splitBase)     Build-Depends:       random >=1 && <2,-      base >= 3 && <5+      base >=3 && <5   Else     Build-Depends:-      base >= 1.0 && < 3+      base >=1.0 && <3    GHC-Options:      -Wall   Hs-Source-Dirs:   src@@ -77,6 +78,8 @@     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@@ -103,6 +106,7 @@     Sound.MIDI.Monoid     Sound.MIDI.String     Sound.MIDI.Utility+    Sound.MIDI.Message.Class.Utility     -- type definition     Sound.MIDI.ControllerPrivate     -- didactic example
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/File.hs view
@@ -32,7 +32,7 @@ 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@@ -77,12 +77,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 :          []
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), )
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/KeySignature.hs view
@@ -21,7 +21,6 @@          (enumRandomR, boundedEnumRandom, chooseEnum, checkRange, )  import Test.QuickCheck (Arbitrary(arbitrary), )-import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), )  import Data.Int (Int8, )
+ 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.Fallible 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/Message.hs view
@@ -34,8 +34,6 @@ 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
src/Sound/MIDI/Message/Channel.hs view
@@ -30,10 +30,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,7 +41,6 @@      messageChannel :: Channel,      messageBody    :: Body    }-     -- ToDo: make nicer Show instance      deriving (Show, Eq, Ord)  data Body =@@ -62,6 +60,13 @@             (20, liftM Voice arbitrary) :             ( 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)   -- * serialization
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, )
src/Sound/MIDI/Message/Class/Check.hs view
@@ -1,5 +1,7 @@ module Sound.MIDI.Message.Class.Check 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, ) @@ -21,6 +23,12 @@ 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)@@ -34,6 +42,27 @@    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 ::
+ src/Sound/MIDI/Message/Class/Construct.hs view
@@ -0,0 +1,95 @@+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.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
src/Sound/MIDI/Message/Class/Query.hs view
@@ -1,5 +1,7 @@ module Sound.MIDI.Message.Class.Query 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, ) @@ -8,7 +10,9 @@ import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg 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@@ -19,6 +23,12 @@ 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))@@ -67,6 +77,27 @@       ChannelMsg.Mode m <-          Just $ ChannelMsg.messageBody msg       return (ChannelMsg.messageChannel msg, m)+++{- |+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 ::
+ src/Sound/MIDI/Message/Class/Utility.hs view
@@ -0,0 +1,20 @@+module Sound.MIDI.Message.Class.Utility where++import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, )++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+++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/Parser/Stream.hs view
@@ -78,6 +78,7 @@    drop :: NonNeg.Integer -> str -> str  newtype ByteList = ByteList MIO.ByteList+   deriving Show  instance ByteStream ByteList where    switchL n j (ByteList xss) =
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
test/Main.hs view
@@ -26,8 +26,9 @@  import qualified Data.ByteString.Lazy as B import qualified Data.List as List+import qualified Data.List.HT as ListHT+import qualified Data.List.Match as Match -import Sound.MIDI.Utility (viewR, dropMatch, ) import Control.Monad.Trans.Class (lift, ) import Control.Monad (when, ) @@ -165,10 +166,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)