{- | Loading MIDI Files This module loads and parses a MIDI File. It can convert it into a 'MIDIFile.T' data type object or simply print out the contents of the file. -} {- The MIDI file format is quite similar to the Interchange File Format (IFF) of Electronic Arts. But it seems to be not sensible to re-use functionality from the @iff@ package. -} module Sound.MIDI.File.Load ( fromFile, fromByteList, maybeFromByteList, maybeFromByteString, showFile, ) where import Sound.MIDI.File import qualified Sound.MIDI.File as MIDIFile import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as Event import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, readBinaryFile, ) import Sound.MIDI.String (unlinesS) import Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as RestrictedParser import qualified Sound.MIDI.Parser.ByteString as ByteStringParser import qualified Sound.MIDI.Parser.Stream as StreamParser import qualified Sound.MIDI.Parser.File as FileParser import qualified Sound.MIDI.Parser.Status as StatusParser import qualified Sound.MIDI.Parser.Report as Report import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM, liftM2, ) import qualified Data.ByteString.Lazy as B import qualified Control.Monad.Exception.Asynchronous as Async import Data.List (genericReplicate, genericLength, ) import Data.Maybe (catMaybes, ) {- | The main load function. Warnings are written to standard error output and an error is signaled by a user exception. This function will not be appropriate in GUI applications. For these, use 'maybeFromByteString' instead. -} fromFile :: FilePath -> IO MIDIFile.T fromFile = FileParser.runIncompleteFile parse {- fromFile :: FilePath -> IO MIDIFile.T fromFile filename = do report <- fmap maybeFromByteList $ readBinaryFile filename mapM_ (hPutStrLn stderr . ("MIDI.File.Load warning: " ++)) (StreamParser.warnings report) either (ioError . userError . ("MIDI.File.Load error: " ++)) return (StreamParser.result report) -} {- | This function ignores warnings, turns exceptions into errors, and return partial results without warnings. Use this only in testing but never in production code! -} fromByteList :: ByteList -> MIDIFile.T fromByteList contents = either error id (Report.result (maybeFromByteList contents)) maybeFromByteList :: ByteList -> Report.T MIDIFile.T maybeFromByteList = StreamParser.runIncomplete parse . StreamParser.ByteList maybeFromByteString :: B.ByteString -> Report.T MIDIFile.T maybeFromByteString = ByteStringParser.runIncomplete parse {- | A MIDI file is made of /chunks/, each of which is either a /header chunk/ or a /track chunk/. To be correct, it must consist of one header chunk followed by any number of track chunks, but for robustness's sake we ignore 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.Fragile parser) MIDIFile.T parse = getChunk >>= \ (typ, hdLen) -> case typ of "MThd" -> do (format, nTracks, division) <- RestrictedParser.runFragile hdLen getHeader excTracks <- lift $ Parser.zeroOrMoreInc (getTrackChunk >>= Async.mapM (lift . liftMaybe removeEndOfTrack)) flip Async.mapM excTracks $ \tracks -> do let n = genericLength tracks lift $ Parser.warnIf (n /= nTracks) ("header says " ++ show nTracks ++ " tracks, but " ++ show n ++ " tracks were found") return (MIDIFile.Cons format division $ catMaybes tracks) _ -> lift (Parser.warn ("found Alien chunk <" ++ typ ++ ">")) >> Parser.skip hdLen >> parse liftMaybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) liftMaybe f = maybe (return Nothing) (liftM Just . f) {- | There are two ways to mark the end of the track: The end of the event list and the meta event 'EndOfTrack'. Thus the end marker is redundant and we remove a 'EndOfTrack' at the end of the track and complain about all 'EndOfTrack's within the event list. -} removeEndOfTrack :: Parser.C parser => Track -> parser Track removeEndOfTrack xs = maybe (Parser.warn "Empty track, missing EndOfTrack" >> return xs) (\(initEvents, lastEvent) -> let (eots, track) = EventList.partition isEndOfTrack initEvents in do Parser.warnIf (not $ EventList.null eots) "EndOfTrack inside a track" Parser.warnIf (not $ isEndOfTrack $ snd lastEvent) "Track does not end with EndOfTrack" return track) (EventList.viewR xs) isEndOfTrack :: Event.T -> Bool isEndOfTrack ev = case ev of Event.MetaEvent MetaEvent.EndOfTrack -> True _ -> False {- removeEndOfTrack :: Track -> Track removeEndOfTrack = maybe (error "Track does not end with EndOfTrack") (\(ev,evs) -> case snd ev of MetaEvent EndOfTrack -> if EventList.null evs then evs else error "EndOfTrack inside a track" _ -> uncurry EventList.cons ev (removeEndOfTrack evs)) . EventList.viewL -} {- | Parse a chunk, whether a header chunk, a track chunk, or otherwise. A chunk consists of a four-byte type code (a header is @MThd@; a track is @MTrk@), four bytes for the size of the coming data, and the data itself. -} 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.Fragile parser) (Maybe Track) getTrackChunk = do (typ, len) <- getChunk if typ=="MTrk" then liftM (fmap Just) $ lift $ RestrictedParser.run len $ StatusParser.run getTrack else lift (Parser.warn ("found Alien chunk <" ++ typ ++ "> in track section")) >> Parser.skip len >> return (Async.pure Nothing) {- | Parse a Header Chunk. A header consists of a format (0, 1, or 2), 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.Fragile parser (MIDIFile.Type, NonNeg.Int, Division) getHeader = do format <- makeEnum =<< get2 nTracks <- liftM (NonNeg.fromNumberMsg "MIDI.Load.getHeader") get2 division <- getDivision return (format, nTracks, division) {- | 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.Fragile parser Division getDivision = do x <- get1 y <- get1 return $ if x < 128 then Ticks (NonNeg.fromNumberMsg "MIDI.Load.getDivision" (x*256+y)) else SMPTE (256-x) y {- | A track is a series of events. Parse a track, stopping when the size is zero. -} getTrack :: Parser.C parser => Parser.Partial (StatusParser.T parser) MIDIFile.Track getTrack = liftM (fmap EventList.fromPairList) (Parser.zeroOrMore Event.getTrackEvent) -- * show contents of a MIDI file for debugging {-# DEPRECATED showFile "only use this for debugging" #-} {- | Functions to show the decoded contents of a MIDI file in an easy-to-read format. This is for debugging purposes and should not be used in production code. -} showFile :: FilePath -> IO () showFile fileName = putStr . showChunks =<< readBinaryFile fileName showChunks :: ByteList -> String showChunks mf = showMR (lift getChunks) (\(Async.Exceptional me cs) -> unlinesS (map pp cs) . maybe id (\e -> showString ("incomplete chunk list: " ++ e ++ "\n")) me) mf "" where pp :: (String, ByteList) -> ShowS pp ("MThd",contents) = showString "Header: " . showMR getHeader shows contents pp ("MTrk",contents) = showString "Track:\n" . showMR (lift $ StatusParser.run getTrack) (\(Async.Exceptional me track) str -> EventList.foldr MIDIFile.showTime (\e -> MIDIFile.showEvent e . showString "\n") (maybe "" (\e -> "incomplete track: " ++ e ++ "\n") me ++ str) track) contents pp (ty,contents) = showString "Alien Chunk: " . showString ty . showString " " . shows contents . showString "\n" 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) . either showString pp (Report.result report) {- | The two functions, the 'getChunk' and 'getChunks' parsers, do not combine directly into a single master parser. Rather, they should be used to chop parts of a midi file up into chunks of bytes which can be outputted separately. Chop a MIDI file into chunks returning: * list of /chunk-type/-contents pairs; and * leftover slop (should be empty in correctly formatted file) -} getChunks :: Parser.C parser => Parser.Partial parser [(String, ByteList)] getChunks = Parser.zeroOrMore $ do (typ, len) <- getChunk body <- sequence (genericReplicate len getByte) return (typ, body)