module ZMidi.Core.WriteFile
(
writeMidi
) where
import ZMidi.Core.Datatypes
import Data.Binary.Put
import Control.Applicative
import Data.Bits
import qualified Data.ByteString.Lazy as L
import Data.Char (ord)
import Data.Int
import Data.Word
import System.IO
writeMidi :: FilePath -> MidiFile -> IO ()
writeMidi filename midi =
openBinaryFile filename WriteMode >>= \hdl ->
L.hPut hdl (runPut $ putMidiFile midi) >>
hClose hdl
putMidiFile :: MidiFile -> PutM ()
putMidiFile (MidiFile hdr trks) =
putHeader hdr *> mapM_ putTrack trks
putHeader :: Header -> PutM ()
putHeader (Header fmt n td) =
putString "MThd" *> putWord32be 6 *>
putFormat fmt *> putWord16be n *> putTimeDivision td
putTrack :: Track -> PutM ()
putTrack (Track ms) =
putString "MTrk" *> (putWord32be $ fromIntegral $ L.length bs)
*> putLazyByteString bs
where
bs = runPut (mapM_ putMessage ms)
putFormat :: Format -> PutM ()
putFormat MF0 = putWord16be 0
putFormat MF1 = putWord16be 1
putFormat MF2 = putWord16be 2
putTimeDivision :: TimeDivision -> PutM ()
putTimeDivision (FPS n) = putWord16be (n `setBit` 15)
putTimeDivision (TPB n) = putWord16be (n `clearBit` 15)
putMessage :: Message -> PutM ()
putMessage (dt,evt) = putVarlen dt *> putEvent evt
putEvent :: Event -> PutM ()
putEvent (DataEvent e) = putDataEvent e
putEvent (VoiceEvent e) = putVoiceEvent e
putEvent (SysExEvent e) = putSysExEvent e
putEvent (SysCommonEvent e) = putSysCommonEvent e
putEvent (SysRealTimeEvent e) = putSysRealTimeEvent e
putEvent (MetaEvent e) = putMetaEvent e
putDataEvent :: DataEvent -> PutM ()
putDataEvent (Data1 tag) = putWord8 tag
putVoiceEvent :: VoiceEvent -> PutM ()
putVoiceEvent (NoteOff c n v) =
putWord8 (0x8 `u4l4` c) *> putWord8 n *> putWord8 v
putVoiceEvent (NoteOn c n v) =
putWord8 (0x9 `u4l4` c) *> putWord8 n *> putWord8 v
putVoiceEvent (NoteAftertouch c n v) =
putWord8 (0xA `u4l4` c) *> putWord8 n *> putWord8 v
putVoiceEvent (Controller c n v) =
putWord8 (0xB `u4l4` c) *> putWord8 n *> putWord8 v
putVoiceEvent (ProgramChange c n) =
putWord8 (0xC `u4l4` c) *> putWord8 n
putVoiceEvent (ChanAftertouch c v) =
putWord8 (0xD `u4l4` c) *> putWord8 v
putVoiceEvent (PitchBend c v) =
putWord8 (0xE `u4l4` c) *> putWord16be v
putSysExEvent :: SysExEvent -> PutM ()
putSysExEvent (SysEx n ws) =
putWord8 0xF0 *> putVarlen n *> mapM_ putWord8 ws
putSysCommonEvent :: SysCommonEvent -> PutM ()
putSysCommonEvent (QuarterFrame sb) =
putWord8 0xF1 *> putSplitByte sb
putSysCommonEvent (SongPosPointer lsb msb) =
putWord8 0xF2 *> putWord8 lsb *> putWord8 msb
putSysCommonEvent (SongSelect w) =
putWord8 0xF3 *> putWord8 w
putSysCommonEvent (Common_undefined tag) =
putWord8 tag
putSysCommonEvent TuneRequest =
putWord8 0xF6
putSysCommonEvent EOX =
putWord8 0xF7
putSysRealTimeEvent :: SysRealTimeEvent -> PutM ()
putSysRealTimeEvent TimingClock = putWord8 0xF8
putSysRealTimeEvent (RT_undefined tag) = putWord8 tag
putSysRealTimeEvent StartSequence = putWord8 0xFA
putSysRealTimeEvent ContinueSequence = putWord8 0xFB
putSysRealTimeEvent StopSequence = putWord8 0xFC
putSysRealTimeEvent ActiveSensing = putWord8 0xFE
putSysRealTimeEvent SystemReset = putWord8 0xFF
putMetaEvent :: MetaEvent -> PutM ()
putMetaEvent (TextEvent ty ss) =
putWord8 0xFF *> putWord8 (texttype ty)
*> putVarlen (fromIntegral $ length ss)
*> putString ss
putMetaEvent (SequenceNumber n) =
putWord8 0xFF *> putWord8 0x00 *> prefixLen 2 (putWord16be n)
putMetaEvent (ChannelPrefix i ch) =
putWord8 0xFF *> putWord8 0x20 *> prefixLen i (putWord8 ch)
putMetaEvent (EndOfTrack) =
putWord8 0xFF *> putWord8 0x2F *> prefixLen 0 (pure ())
putMetaEvent (SetTempo t) =
putWord8 0xFF *> putWord8 0x51 *> prefixLen 3 (putWord24be t)
putMetaEvent (SMPTEOffset hr mn sc fr sfr) =
putWord8 0xFF *> putWord8 0x54 *> prefixLen 5 body
where
body = putWord8 hr *> putWord8 mn *> putWord8 sc
*> putWord8 fr *> putWord8 sfr
putMetaEvent (TimeSignature nmr dnm met nps) =
putWord8 0xFF *> putWord8 0x58 *> prefixLen 4 body
where
body = putWord8 nmr *> putWord8 dnm *> putWord8 met *> putWord8 nps
putMetaEvent (KeySignature ky sc) =
putWord8 0xFF *> putWord8 0x59 *> prefixLen 2 body
where
body = putWord8 (wrapint ky) *> putWord8 (wscale sc)
putMetaEvent (SSME i ws) =
putWord8 0xFF *> putWord8 0x7F *> putVarlen i *> mapM_ putWord8 ws
prefixLen :: Word8 -> PutM () -> PutM ()
prefixLen n out = putWord8 n *> out
putSplitByte :: SplitByte -> PutM ()
putSplitByte a = putWord8 (joinByte a)
infixr 5 `u4l4`
u4l4 :: Word8 -> Word8 -> Word8
a `u4l4` b = (a `shiftL` 4) + b
wrapint :: Int8 -> Word8
wrapint i | i < 0 = fromIntegral $ i' + 256
| otherwise = fromIntegral i
where
i' :: Int
i' = fromIntegral i
wscale :: ScaleType -> Word8
wscale MAJOR = 0x00
wscale MINOR = 0x01
putWord24be :: Word32 -> PutM ()
putWord24be i = putWord8 c *> putWord8 b *> putWord8 a
where
(a, r1) = lowerEight i
(b, r2) = lowerEight r1
(c, _) = lowerEight r2
lowerEight :: (Bits a, Integral a) => a -> (Word8, a)
lowerEight n = (fromIntegral lower8, remain)
where
remain = n `shiftR` 8
lower8 = n .&. 0xff
putVarlen :: Word32 -> PutM ()
putVarlen = step . toVarlen where
step (V1 a) = putWord8 a
step (V2 a b) = putWord8 a *> putWord8 b
step (V3 a b c) = putWord8 a *> putWord8 b *> putWord8 c
step (V4 a b c d) = putWord8 a *> putWord8 b *> putWord8 c *> putWord8 d
putString :: String -> PutM ()
putString s = putLazyByteString (L.pack $ fmap (fromIntegral . ord) s)
texttype :: TextType -> Word8
texttype GENERIC_TEXT = 0x01
texttype COPYRIGHT_NOTICE = 0x02
texttype SEQUENCE_NAME = 0x03
texttype INSTRUMENT_NAME = 0x04
texttype LYRICS = 0x05
texttype MARKER = 0x06
texttype CUE_POINT = 0x07