midi 0.2.1.1 → 0.2.1.2
raw patch · 33 files changed
+603/−513 lines, 33 filesdep +mididep ~QuickCheckdep ~basedep ~bytestring
Dependencies added: midi
Dependency ranges changed: QuickCheck, base, bytestring, event-list, explicit-exception, non-negative, transformers, utility-ht
Files
- midi.cabal +24/−16
- parser/Sound/MIDI/Parser/Class.hs +174/−0
- parser/Sound/MIDI/Parser/Exception.hs +24/−0
- parser/Sound/MIDI/Parser/Stream.hs +139/−0
- parser/Sound/MIDI/Parser/Warning.hs +28/−0
- src/Sound/MIDI/File/Event.hs +2/−2
- src/Sound/MIDI/File/Event/Meta.hs +2/−2
- src/Sound/MIDI/File/Event/SystemExclusive.hs +1/−1
- src/Sound/MIDI/File/Load.hs +7/−7
- src/Sound/MIDI/KeySignature.hs +2/−2
- src/Sound/MIDI/MachineControl.hs +1/−1
- src/Sound/MIDI/Manufacturer.hs +1/−1
- src/Sound/MIDI/Message.hs +3/−3
- src/Sound/MIDI/Message/Channel.hs +2/−2
- src/Sound/MIDI/Message/Channel/Mode.hs +1/−1
- src/Sound/MIDI/Message/Channel/Voice.hs +1/−1
- src/Sound/MIDI/Message/System.hs +2/−2
- 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/−1
- src/Sound/MIDI/Parser/ByteString.hs +11/−2
- src/Sound/MIDI/Parser/Class.hs +0/−174
- src/Sound/MIDI/Parser/Exception.hs +0/−24
- src/Sound/MIDI/Parser/File.hs +16/−8
- src/Sound/MIDI/Parser/Primitive.hs +14/−14
- src/Sound/MIDI/Parser/Restricted.hs +15/−7
- src/Sound/MIDI/Parser/Status.hs +3/−3
- src/Sound/MIDI/Parser/Stream.hs +0/−131
- src/Sound/MIDI/Parser/Warning.hs +0/−28
- test/Common.hs +6/−0
- test/Example.hs +45/−0
- test/Main.hs +54/−75
- test/Parser.hs +19/−0
midi.cabal view
@@ -1,5 +1,5 @@ Name: midi-Version: 0.2.1.1+Version: 0.2.1.2 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -7,8 +7,8 @@ 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, GHC==7.4.1, GHC==7.6.1-Cabal-Version: >=1.6+Tested-With: GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.6.1, GHC==7.8.2+Cabal-Version: >=1.14 Build-Type: Simple Synopsis: Handling of MIDI messages and files Description:@@ -30,15 +30,11 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/midi/- tag: 0.2.1.1+ tag: 0.2.1.2 Flag splitBase description: Choose the new smaller, split-up base package. -Flag buildTests- description: Build test executables- default: False- Library Build-Depends: event-list >=0.0.9 && < 0.2,@@ -58,8 +54,9 @@ Build-Depends: base >=1.0 && <3 + Default-Language: Haskell2010 GHC-Options: -Wall- Hs-Source-Dirs: src+ Hs-Source-Dirs: src, parser Exposed-Modules: Sound.MIDI.File Sound.MIDI.File.Event@@ -112,12 +109,23 @@ -- 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
+ 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,24 @@+{- |+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
+ parser/Sound/MIDI/Parser/Stream.hs view
@@ -0,0 +1,139 @@+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 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.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 = return+ (<*>) = ap++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+ 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/File/Event.hs view
@@ -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
src/Sound/MIDI/File/Event/Meta.hs view
@@ -112,11 +112,11 @@ -- * 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
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
@@ -101,13 +101,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 +177,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 +202,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 +214,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 +273,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/KeySignature.hs view
@@ -171,10 +171,10 @@ asMinor = minor (Accidentals 7) -get :: (Parser.C parser) => Parser.Fallible parser T+get :: (Parser.C parser) => Parser.Fragile parser T get = liftM2 (flip Cons) getAccidentals getEnum -getAccidentals :: (Parser.C parser) => Parser.Fallible parser Accidentals+getAccidentals :: (Parser.C parser) => Parser.Fragile parser Accidentals getAccidentals = makeEnum . fromIntegral . (id :: Int8 -> Int8) . fromIntegral =<< getByte
src/Sound/MIDI/MachineControl.hs view
@@ -125,7 +125,7 @@ then return Nothing else liftM Just $ getCommand code -getCommand :: Parser.C parser => Word8 -> Parser.Fallible parser Command+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
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
@@ -38,7 +38,7 @@ -- deriving (Show) -get :: Parser.C parser => Parser.Fallible parser T+get :: Parser.C parser => Parser.Fragile parser T get = get1 >>= \code -> if code >= 0xF0@@ -46,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@@ -55,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
src/Sound/MIDI/Message/Channel.hs view
@@ -81,7 +81,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@@ -104,7 +104,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
src/Sound/MIDI/Message/Channel/Mode.hs view
@@ -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
@@ -406,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
src/Sound/MIDI/Message/System.hs view
@@ -26,7 +26,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 +38,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
@@ -25,7 +25,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/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 @@ -40,7 +42,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 +57,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@@ -65,6 +67,13 @@ fromGet p = Cons $ lift p ++instance Functor T where+ fmap = liftM++instance Applicative T where+ pure = return+ (<*>) = ap instance Monad T where return = Cons . return
− 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,6 +57,13 @@ +instance Functor T where+ fmap = liftM++instance Applicative T where+ pure = return+ (<*>) = ap+ instance Monad T where return = Cons . return x >>= y = Cons $ decons . y =<< decons x@@ -66,8 +74,8 @@ ioeTry :: IO a -> IO (Either IOError a) ioeTry = Exc.try -fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a-fallibleFromIO act =+fragileFromIO :: (IO.Handle -> IO a) -> Parser.Fragile T a+fragileFromIO act = Sync.ExceptionalT . Cons . lift . fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act =<< lift (Cons ask)@@ -76,6 +84,6 @@ 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,6 +41,13 @@ 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@@ -48,10 +56,10 @@ 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
@@ -32,17 +32,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
− src/Sound/MIDI/Parser/Stream.hs
@@ -1,131 +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- 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)--}
− 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]
+ 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,43 +1,30 @@ {- 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 Common (check, )+import qualified Example+import qualified Parser+ import qualified Sound.MIDI.File as MidiFile import qualified Sound.MIDI.File.Load as Load import qualified Sound.MIDI.File.Save as Save -import qualified Sound.MIDI.File.Event.Meta as MetaEvent-import qualified Sound.MIDI.File.Event as Event--import qualified Sound.MIDI.Message.Channel as ChannelMsg-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg- import qualified Sound.MIDI.Parser.Report as Report-import qualified Sound.MIDI.Parser.Class as Parser-import qualified Sound.MIDI.Parser.Stream as StreamParser import qualified Data.EventList.Relative.TimeBody as EventList-import Data.EventList.Relative.MixedBody ((/.), (./), ) import qualified Data.ByteString.Lazy as B import qualified Data.List as List import qualified Data.List.HT as ListHT import qualified Data.List.Match as Match+import Data.Int (Int64, ) -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 Debug.Trace (trace) @@ -45,29 +32,6 @@ 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@@ -149,14 +113,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@@ -182,13 +138,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@@ -200,9 +159,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 :@@ -210,29 +169,49 @@ 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 "saveLoadMaybeByteList" saveLoadMaybeByteList+ check "saveLoadByteList" saveLoadByteList+-- check "saveLoadFile" saveLoadFile+ check "loadSaveByteString" loadSaveByteString+ check "loadSaveCompressedByteString" loadSaveCompressedByteString+ check "loadSaveByteList" loadSaveByteList - quickCheck restrictionByteList+ check "restrictionByteList" restrictionByteList - quickCheck lazinessZeroOrMoreByteList- quickCheck lazinessByteList+ check "lazinessZeroOrMoreByteList" Parser.lazinessZeroOrMoreByteList+ check "lazinessByteList" lazinessByteList - quickCheck corruptionByteList- quickCheck corruptionByteString+ 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