diff --git a/midi.cabal b/midi.cabal --- a/midi.cabal +++ b/midi.cabal @@ -1,5 +1,5 @@ Name: midi -Version: 0.2.0.1 +Version: 0.2.1 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -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 diff --git a/src/Sound/MIDI/Bit.hs b/src/Sound/MIDI/Bit.hs --- a/src/Sound/MIDI/Bit.hs +++ b/src/Sound/MIDI/Bit.hs @@ -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 diff --git a/src/Sound/MIDI/ControllerPrivate.hs b/src/Sound/MIDI/ControllerPrivate.hs --- a/src/Sound/MIDI/ControllerPrivate.hs +++ b/src/Sound/MIDI/ControllerPrivate.hs @@ -5,7 +5,6 @@ enumRandomR, boundedEnumRandom, chooseEnum, ) import Test.QuickCheck (Arbitrary(arbitrary), ) -import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), ) diff --git a/src/Sound/MIDI/File.hs b/src/Sound/MIDI/File.hs --- a/src/Sound/MIDI/File.hs +++ b/src/Sound/MIDI/File.hs @@ -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 : [] diff --git a/src/Sound/MIDI/File/Event.hs b/src/Sound/MIDI/File/Event.hs --- a/src/Sound/MIDI/File/Event.hs +++ b/src/Sound/MIDI/File/Event.hs @@ -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), ) diff --git a/src/Sound/MIDI/General.hs b/src/Sound/MIDI/General.hs --- a/src/Sound/MIDI/General.hs +++ b/src/Sound/MIDI/General.hs @@ -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), ) diff --git a/src/Sound/MIDI/KeySignature.hs b/src/Sound/MIDI/KeySignature.hs --- a/src/Sound/MIDI/KeySignature.hs +++ b/src/Sound/MIDI/KeySignature.hs @@ -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, ) diff --git a/src/Sound/MIDI/MachineControl.hs b/src/Sound/MIDI/MachineControl.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/MachineControl.hs @@ -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 diff --git a/src/Sound/MIDI/Message.hs b/src/Sound/MIDI/Message.hs --- a/src/Sound/MIDI/Message.hs +++ b/src/Sound/MIDI/Message.hs @@ -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 diff --git a/src/Sound/MIDI/Message/Channel.hs b/src/Sound/MIDI/Message/Channel.hs --- a/src/Sound/MIDI/Message/Channel.hs +++ b/src/Sound/MIDI/Message/Channel.hs @@ -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 diff --git a/src/Sound/MIDI/Message/Channel/Mode.hs b/src/Sound/MIDI/Message/Channel/Mode.hs --- a/src/Sound/MIDI/Message/Channel/Mode.hs +++ b/src/Sound/MIDI/Message/Channel/Mode.hs @@ -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, ) diff --git a/src/Sound/MIDI/Message/Class/Check.hs b/src/Sound/MIDI/Message/Class/Check.hs --- a/src/Sound/MIDI/Message/Class/Check.hs +++ b/src/Sound/MIDI/Message/Class/Check.hs @@ -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 :: diff --git a/src/Sound/MIDI/Message/Class/Construct.hs b/src/Sound/MIDI/Message/Class/Construct.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Class/Construct.hs @@ -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 diff --git a/src/Sound/MIDI/Message/Class/Query.hs b/src/Sound/MIDI/Message/Class/Query.hs --- a/src/Sound/MIDI/Message/Class/Query.hs +++ b/src/Sound/MIDI/Message/Class/Query.hs @@ -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 :: diff --git a/src/Sound/MIDI/Message/Class/Utility.hs b/src/Sound/MIDI/Message/Class/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Class/Utility.hs @@ -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 diff --git a/src/Sound/MIDI/Parser/Stream.hs b/src/Sound/MIDI/Parser/Stream.hs --- a/src/Sound/MIDI/Parser/Stream.hs +++ b/src/Sound/MIDI/Parser/Stream.hs @@ -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) = diff --git a/src/Sound/MIDI/Utility.hs b/src/Sound/MIDI/Utility.hs --- a/src/Sound/MIDI/Utility.hs +++ b/src/Sound/MIDI/Utility.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)