midi-0.0.4: src/Sound/MIDI/File/Load.hs
{- |
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, fromStream, maybeFromStream, showFile)
where
import Sound.MIDI.File
import qualified Sound.MIDI.File as MIDIFile
import qualified Sound.MIDI.Event as MIDIEvent
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg
import Sound.MIDI.IO (ByteString, readBinaryFile, stringCharFromByte)
import qualified Sound.MIDI.Bit as Bit
import Data.Bits (testBit, clearBit)
import Data.Word (Word8)
import Data.Maybe (mapMaybe, fromMaybe)
import Sound.MIDI.String (unlinesS)
import qualified Sound.MIDI.Parser as Parser
import qualified Sound.MIDI.ParserState as ParserState
import qualified Control.Monad.State as State
import Control.Monad (replicateM, liftM, liftM2)
import Control.Monad.State (StateT(StateT, runStateT), evalStateT, lift)
{- |
The main load function.
-}
fromFile :: FilePath -> IO MIDIFile.T
fromFile = liftM fromStream . readBinaryFile
fromStream :: ByteString -> MIDIFile.T
fromStream contents =
case maybeFromStream contents of
Right (mf,[]) -> mf
Right _ -> error "Garbage left over." -- return mf
Left msg -> error ("MIDI.Load.fromStream: " ++ msg)
-- error "Error reading midi file: unfamiliar format or file corrupt."
maybeFromStream :: ByteString -> Either String (MIDIFile.T, ByteString)
maybeFromStream = evalParser parse
evalParser :: ByteParser a -> ByteString -> Either String (a, ByteString)
evalParser = runStateT
{- |
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 :: ByteParser MIDIFile.T
parse =
getChunk >>= \ chunk ->
case chunk of
Header (format, nTracks, division) ->
liftM
(MIDIFile.Cons format division .
map removeEndOfTrack .
mapMaybe trackFromChunk)
(replicateM (NonNeg.toNumber nTracks) getChunk)
_ -> parse
{- |
Check if a chunk contains a track.
Like 'parse', if a chunk is not a track chunk, it is just ignored.
-}
trackFromChunk :: Chunk -> Maybe Track
trackFromChunk (Track t) = Just t
trackFromChunk _ = Nothing
{- |
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 :: Track -> Track
removeEndOfTrack xs =
fromMaybe
(error "Empty track, missing EndOfTrack")
(do (initEvents, lastEvent) <- EventList.viewR xs
let (eots, track) =
EventList.partition isEndOfTrack initEvents
if EventList.null eots
then return ()
else error "EndOfTrack inside a track"
if isEndOfTrack (snd lastEvent)
then return ()
else error "Track does not end with EndOfTrack"
return track)
isEndOfTrack :: Event -> Bool
isEndOfTrack ev =
case ev of
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 :: ByteParser Chunk
getChunk =
do
(ty, body) <- getPlainChunk
case ty of
"MThd" ->
return $ Header $
case evalParser getHeader body of
Right (hd,[]) -> hd
Right (_,_) -> error "header chunk too large"
Left msg -> error ("getChunk header: " ++ msg)
"MTrk" ->
return $ Track $
either (\msg -> error ("getChunk track: " ++ msg)) id $
evalStateT (evalStateT getTrack initReadEvent) body
_ -> return (AlienChunk ty body)
data Chunk =
Header (MIDIFile.Type, NonNeg.Int, Division)
| Track Track
| AlienChunk String ByteString
deriving Eq
{- |
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 :: ByteParser (MIDIFile.Type, NonNeg.Int, Division)
getHeader =
do
format <- liftM toEnum 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 :: ByteParser 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 :: TrackParser MIDIFile.Track
getTrack =
liftM
EventList.fromPairList
(ParserState.zeroOrMore getSchedEvent)
{- |
Each event is preceded by the delta time: the time in ticks between the
last event and the current event. Parse a time and an event, ignoring
System Exclusive messages.
-}
getSchedEvent :: TrackParser MIDIFile.SchedEvent
getSchedEvent = liftM2 (,) (lift getVar) getEvent
{- |
Parse an event. Note that in the case of a regular MIDI Event, the tag is
the status, and we read the first byte of data before we call 'getMIDIEvent'.
In the case of a MIDIEvent with running status, we find out the status from
the parser (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.
-}
getEvent :: TrackParser MIDIFile.Event
getEvent =
do
tag <- lift get1
case tag of
240 -> liftM SysExStart $ lift (getBigN =<< getVar)
247 -> liftM SysExCont $ lift (getBigN =<< getVar)
255 -> lift $
do
code <- get1
size <- getVar
liftM MetaEvent (getMetaEvent code size)
x -> if x>127
then let parseEv = decodeStatus tag
in putEventParser parseEv >> lift (get1 >>= parseEvent parseEv)
else -- running status
lift . flip parseEvent tag =<< getEventParser
{- |
Simpler version of 'getTrack', used in the Show functions.
-}
getPlainTrack :: TrackParser MIDIFile.Track
getPlainTrack =
liftM
EventList.fromPairList
(ParserState.oneOrMore getSchedEvent)
newtype EventParser =
EventParser {parseEvent :: Int -> ByteParser MIDIFile.Event}
{- |
Find out the status (MIDIEvent type and channel) given a byte of data.
-}
decodeStatus :: Int -> EventParser
decodeStatus tag =
let (code, channel) = Bit.splitAt 4 tag
in EventParser (getMIDIEvent code (MIDIEvent.toChannel channel))
{- |
Parse a MIDI Event.
Note that since getting the first byte is a little complex
(there are issues with running status),
it has already been handled for us by 'getEvent'.
-}
getMIDIEvent :: Int -> MIDIEvent.Channel -> Int -> ByteParser MIDIFile.Event
getMIDIEvent code channel firstData =
let pitch = MIDIEvent.toPitch firstData
getVel = liftM MIDIEvent.toVelocity get1
getME =
case code of
08 -> liftM (MIDIEvent.NoteOff pitch) getVel
09 -> liftM (MIDIEvent.NoteOn pitch) getVel
10 -> liftM (MIDIEvent.PolyAfter pitch) get1
11 -> liftM (MIDIEvent.Control (toEnum firstData)) get1
12 -> return (MIDIEvent.ProgramChange (MIDIEvent.toProgram firstData))
13 -> return (MIDIEvent.MonoAfter firstData)
14 -> liftM (\msb -> MIDIEvent.PitchBend (firstData+128*msb)) get1
_ -> fail ("invalid MIDIEvent code:" ++ show code)
in liftM (MIDIEvent channel) getME
{- |
Parse a MetaEvent.
-}
getMetaEvent :: Int -> NonNeg.Integer -> ByteParser MetaEvent
getMetaEvent code size =
case code of
000 -> liftM SequenceNum get2
001 -> getText size TextEvent
002 -> getText size Copyright
003 -> getText size TrackName
004 -> getText size InstrName
005 -> getText size Lyric
006 -> getText size Marker
007 -> getText size CuePoint
032 -> liftM (MIDIPrefix . MIDIEvent.toChannel) get1
047 -> return EndOfTrack
081 -> liftM (SetTempo . NonNeg.fromNumberMsg "MIDI.Load.getMetaEvent") get3
084 -> do {hrs <- get1 ; mins <- get1 ; secs <- get1;
frames <- get1 ; bits <- get1 ;
return (SMPTEOffset hrs mins secs frames bits)}
088 -> do
n <- get1
d <- get1
c <- get1
b <- get1
return (TimeSig n d c b)
089 -> do
sf <- get1
mi <- get1
return (KeySig (toKeyName sf) (toEnum mi))
127 -> liftM SequencerSpecific (getBigN size)
_ -> liftM (Unknown code) (getBigN size)
getText :: NonNeg.Integer -> (String -> MetaEvent) -> ByteParser MetaEvent
getText size c = liftM c (getString size)
toKeyName :: Int -> Key
toKeyName sf = toEnum (mod (sf+7) 15)
{- |
'getByte' gets a single byte from the input.
-}
getByte :: ByteParser Word8
getByte = StateT $ maybe (Left "reached end of file") Right . viewL
viewL :: [a] -> Maybe (a, [a])
viewL xs =
case xs of
[] -> Nothing
(c:cs) -> Just (c,cs)
{- |
@getN n@ returns n characters (bytes) from the input.
-}
getN :: NonNeg.Int -> ByteParser ByteString
getN n = replicateM (NonNeg.toNumber n) getByte
getString :: NonNeg.Integer -> ByteParser String
getString n = liftM stringCharFromByte (getBigN n)
getBigN :: NonNeg.Integer -> ByteParser ByteString
getBigN n =
sequence $
Bit.replicateBig
(succ (fromIntegral (maxBound :: NonNeg.Int)))
(NonNeg.toNumber n)
getByte
{- |
'get1', 'get2', 'get3', and 'get4' take 1-, 2-, 3-, or
4-byte numbers from the input (respectively), convert the base-256 data
into a single number, and return.
-}
get1 :: ByteParser Int
get1 = liftM fromIntegral getByte
getNByteInt :: NonNeg.Int -> ByteParser Int
getNByteInt n =
liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1)
get2, get3, get4 :: ByteParser Int
get2 = getNByteInt 2
get3 = getNByteInt 3
get4 = getNByteInt 4
{- |
/Variable-length quantities/ are used often in MIDI notation.
They are represented in the following way:
Each byte (containing 8 bits) uses the 7 least significant bits to store information.
The most significant bit is used to signal whether or not more information is coming.
If it's @1@, another byte is coming.
If it's @0@, that byte is the last one.
'getVar' gets a variable-length quantity from the input.
-}
getVar :: ByteParser NonNeg.Integer
getVar =
liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes
{- |
The returned list contains only bytes with the most significant bit cleared.
These are digits of a 128-ary number.
-}
getVarBytes :: ByteParser [Word8]
getVarBytes =
do
digit <- getByte
if flip testBit 7 digit -- if it's the last byte
then liftM (flip clearBit 7 digit :) getVarBytes
else return [digit]
{- |
Functions to show the decoded contents of a MIDI file in an easy-to-read format.
-}
showFile :: FilePath -> IO ()
showFile fileName = putStr . showChunks =<< readBinaryFile fileName
showChunks :: ByteString -> String
showChunks mf = showMR getChunks (unlinesS . map pp) mf ""
where
pp :: (String, ByteString) -> ShowS
pp ("MThd",contents) =
showString "Header: " .
showMR getHeader shows contents
pp ("MTrk",contents) =
showString "Track:\n" .
showMR (evalStateT getPlainTrack initReadEvent)
(\track str ->
EventList.foldr
MIDIFile.showTime
(\e -> MIDIFile.showEvent e . showString "\n")
str track)
contents
pp (ty,contents) =
showString "Chunk: " .
showString ty .
showString " " .
shows contents .
showString "\n"
showMR :: ByteParser a -> (a->ShowS) -> ByteString -> ShowS
showMR m pp contents =
case evalParser m contents of
Left msg ->
showString "Parse failed: " . showString (msg++"\n") . shows contents
Right (a,[] ) -> pp a
Right (a,junk) -> pp a . showString "Junk: " . shows junk
{- |
These two functions, the 'getPlainChunk' 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 :: ByteParser [(String, ByteString)]
getChunks = Parser.zeroOrMore getPlainChunk
getPlainChunk :: ByteParser (String, ByteString)
getPlainChunk =
liftM2 (,)
(getString 4) -- chunk type: header or track
(getN . NonNeg.fromNumberMsg "getPlainChunk" =<< get4)
-- chunk body
type ByteParser a = Parser.T ByteString a
{- |
The 'TrackParser' monad parses a track of a MIDI File.
In MIDI, a shortcut is used for long strings of similar MIDI events:
If a stream of consecutive events all have the same type and channel,
the type and channel can be omitted for all but the first event.
To implement this /feature/,
the parser must keep track of the type and channel of the most recent MIDI Event.
This is done by setting a 'EventParser' parser,
which parses the data bytes according to the currently active event type.
-}
type TrackParser a = ParserState.T EventParser ByteString a
putEventParser :: EventParser -> TrackParser ()
putEventParser = State.put
getEventParser :: TrackParser EventParser
getEventParser = State.get
initReadEvent :: EventParser
initReadEvent =
EventParser (const (return (error "At beginning, no event type set so far")))