module ZMidi.Core.ReadFile
(
readMidi
, ParseErr
, Pos
, ErrMsg
) where
import ZMidi.Core.Datatypes
import ZMidi.Core.Internal.ParserMonad
import Control.Applicative
import Control.Monad
import Data.Bits
import qualified Data.ByteString.Lazy as L
import Data.Word
readMidi :: FilePath -> IO (Either ParseErr MidiFile)
readMidi filename =
liftM (runParser `flip` midiFile) (L.readFile filename)
midiFile :: ParserM MidiFile
midiFile = do
hdr <- header
let i = trackCount hdr
trks <- count i track
return $ MidiFile hdr trks
where
trackCount :: Header -> Int
trackCount (Header _ n _) = fromIntegral n
header :: ParserM Header
header = Header <$> (assertString "MThd" *> assertWord32 (6::Int) *> format)
<*> word16be
<*> timeDivision
track :: ParserM Track
track = liftM Track (trackHeader >>= messages)
trackHeader :: ParserM Word32
trackHeader = assertString "MTrk" >> word32be
messages :: Word32 -> ParserM [Message]
messages i = boundRepeat (fromIntegral i) message
message :: ParserM Message
message = (,) <$> deltaTime <*> event
deltaTime :: ParserM Word32
deltaTime = "delta time" <??> getVarlen
event :: ParserM Event
event = word8 >>= step
where
step n | n == 0xFF = MetaEvent <$> (word8 >>= metaEvent)
| 0xF8 <= n = SysRealTimeEvent <$> sysRealTimeEvent n
| 0xF1 <= n = SysCommonEvent <$> sysCommonEvent n
| n == 0xF0 = SysExEvent <$> sysExEvent
| 0x80 <= n = VoiceEvent <$> voiceEvent (splitByte n)
| otherwise = DataEvent <$> dataEvent n
dataEvent :: Word8 -> ParserM DataEvent
dataEvent tag = pure $ Data1 tag
voiceEvent :: SplitByte -> ParserM VoiceEvent
voiceEvent (SB 0x8 ch) =
"note-off" <??> (NoteOff ch) <$> word8 <*> word8
voiceEvent (SB 0x9 ch) =
"note-on" <??> (NoteOn ch) <$> word8 <*> word8
voiceEvent (SB 0xA ch) =
"note aftertouch" <??> (NoteAftertouch ch) <$> word8 <*> word8
voiceEvent (SB 0xB ch) =
"controller" <??> (Controller ch) <$> word8 <*> word8
voiceEvent (SB 0xC ch) =
"program change" <??> (ProgramChange ch) <$> word8
voiceEvent (SB 0xD ch) =
"chan aftertouch" <??> (ChanAftertouch ch) <$> word8
voiceEvent (SB 0xE ch) =
"pitch bend" <??> (PitchBend ch) <$> word16be
voiceEvent (SB z _ ) = reportError $ "voiceEvent " ++ hexStr z
sysCommonEvent :: Word8 -> ParserM SysCommonEvent
sysCommonEvent 0xF1 =
"quarter frame" <??> QuarterFrame . splitByte <$> word8
sysCommonEvent 0xF2 =
"song pos. pointer" <??> SongPosPointer <$> word8 <*> word8
sysCommonEvent 0xF3 =
"song select" <??> SongSelect <$> word8
sysCommonEvent 0xF4 = pure $ Common_undefined 0xF4
sysCommonEvent 0xF5 = pure $ Common_undefined 0xF5
sysCommonEvent 0xF6 = pure TuneRequest
sysCommonEvent 0xF7 = pure EOX
sysCommonEvent tag = pure $ Common_undefined tag
sysRealTimeEvent :: Word8 -> ParserM SysRealTimeEvent
sysRealTimeEvent 0xF8 = pure TimingClock
sysRealTimeEvent 0xF9 = pure $ RT_undefined 0xF9
sysRealTimeEvent 0xFA = pure StartSequence
sysRealTimeEvent 0xFB = pure ContinueSequence
sysRealTimeEvent 0xFC = pure StopSequence
sysRealTimeEvent 0xFD = pure $ RT_undefined 0xFD
sysRealTimeEvent 0xFE = pure ActiveSensing
sysRealTimeEvent 0xFF = pure SystemReset
sysRealTimeEvent tag = pure $ RT_undefined tag
sysExEvent :: ParserM SysExEvent
sysExEvent = "sys-ex" <??> (uncurry SysEx) <$> getVarlenBytes
metaEvent :: Word8 -> ParserM MetaEvent
metaEvent 0x00 =
"sequence number" <??> SequenceNumber <$> (assertWord8 2 *> word16be)
metaEvent 0x01 = "generic text" <??> textEvent GENERIC_TEXT
metaEvent 0x02 = "copyrightn notice" <??> textEvent COPYRIGHT_NOTICE
metaEvent 0x03 = "sequence name" <??> textEvent SEQUENCE_NAME
metaEvent 0x04 = "instrument name" <??> textEvent INSTRUMENT_NAME
metaEvent 0x05 = "lyrics" <??> textEvent LYRICS
metaEvent 0x06 = "marker" <??> textEvent MARKER
metaEvent 0x07 = "cue point" <??> textEvent CUE_POINT
metaEvent 0x20 =
"channel prefix" <??> ChannelPrefix <$> word8 <*> word8
metaEvent 0x2F =
"end of track" <??> EndOfTrack <$ assertWord8 0
metaEvent 0x51 =
"set tempo" <??> SetTempo <$> (assertWord8 3 *> word24be)
metaEvent 0x54 =
"smpte offset" <??> SMPTEOffset <$> (assertWord8 5 *> word8)
<*> word8 <*> word8
<*> word8 <*> word8
metaEvent 0x58 =
"time signature" <??> TimeSignature <$> (assertWord8 4 *> word8)
<*> word8 <*> word8
<*> word8
metaEvent 0x59 =
"key signature" <??> KeySignature <$> (assertWord8 2 *> int8)
<*> scale
metaEvent 0x7F =
"system specific meta event" <??> (uncurry SSME) <$> getVarlenBytes
metaEvent z = reportError $ "unreconized meta-event " ++ hexStr z
format :: ParserM Format
format = word16be >>= fn
where
fn 0 = return MF0
fn 1 = return MF1
fn 2 = return MF2
fn z = reportError $
"getFormat - unrecognized file format " ++ hexStr z
timeDivision :: ParserM TimeDivision
timeDivision = division <$> word16be
where division i | i `testBit` 15 = FPS (i `clearBit` 15)
| otherwise = TPB i
scale :: ParserM ScaleType
scale = word8 >>= fn
where
fn 0 = return MAJOR
fn 1 = return MINOR
fn z = reportError $ "scale expecting 0 or 1, got " ++ hexStr z
textEvent :: TextType -> ParserM MetaEvent
textEvent ty = (TextEvent ty . snd) <$> getVarlenText
assertWord8 :: Word8 -> ParserM Word8
assertWord8 i = postCheck word8 (==i) msg
where
msg = "assertWord8 - input did not match " ++ show i
assertWord32 :: (Show a, Integral a) => a -> ParserM Word32
assertWord32 i = postCheck word32be ((==i) . fromIntegral) msg
where
msg = "assertWord32 - input did not match " ++ show i
assertString :: String -> ParserM String
assertString s = postCheck (text $ length s) (==s) msg
where
msg = "assertString - input did not match " ++ s
getVarlenText :: ParserM (Word32,String)
getVarlenText = gencount getVarlen char8
getVarlenBytes :: ParserM (Word32,[Word8])
getVarlenBytes = gencount getVarlen word8
getVarlen :: ParserM Word32
getVarlen = liftM fromVarlen step1
where
high a = a `testBit` 7
step1 = word8 >>= \a -> if high a then step2 a else return (V1 a)
step2 a = word8 >>= \b -> if high b then step3 a b else return (V2 a b)
step3 a b = word8 >>= \c -> if high c then do { d <- word8
; return (V4 a b c d)}
else return (V3 a b c)
postCheck :: ParserM a -> (a -> Bool) -> String -> ParserM a
postCheck p check msg = p >>= \ans ->
if check ans then return ans else reportError msg