module Sound.MIDI.File.Save (toFile, toStream, toOpenStream) 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 qualified Sound.MIDI.Bit as Bit
import Data.Bits ((.|.))
import Sound.MIDI.IO (ByteString, writeBinaryFile, stringByteFromChar)
import Control.Monad.Writer (Writer, tell, execWriter)
import Data.Ix (Ix, index)
import Data.List (genericLength)
toFile :: FilePath -> MIDIFile.T -> IO ()
toFile fn mf = writeBinaryFile fn (toStream mf)
toStream, toOpenStream :: MIDIFile.T -> ByteString
toStream = execWriter . outMF outChunk
toOpenStream = execWriter . outMF outOpenChunk
outMF :: OutChunk -> MIDIFile.T -> MIDIWriter ()
outMF outChk (MIDIFile.Cons mft divisn trks) =
do
outChunk "MThd" (do
outInt 2 (fromEnum mft)
outInt 2 (length trks)
outputDivision divisn)
mapM_ (outputTrack outChk) trks
outputDivision :: Division -> MIDIWriter ()
outputDivision (Ticks nticks) =
outInt 2 (NonNeg.toNumber nticks)
outputDivision (SMPTE mode nticks) =
do
outInt 1 (256mode)
outInt 1 nticks
outputTrack :: OutChunk -> Track -> MIDIWriter ()
outputTrack outChk trk =
outChk "MTrk" $
EventList.mapM_ outVar outputEvent $
EventList.snoc trk 0 (MetaEvent EndOfTrack)
outputEvent :: MIDIFile.Event -> MIDIWriter ()
outputEvent e =
case e of
MIDIEvent ch mevent -> outputMIDIEvent ch mevent
MetaEvent mevent -> outputMetaEvent mevent
_ -> error ("don't know, how to write a "++show e++".")
outputMIDIEvent :: MIDIEvent.Channel -> MIDIEvent.T -> MIDIWriter ()
outputMIDIEvent c e =
let outC = outChan c
in case e of
(MIDIEvent.NoteOff p v) -> outC 8 [MIDIEvent.fromPitch p, MIDIEvent.fromVelocity v]
(MIDIEvent.NoteOn p v) -> outC 9 [MIDIEvent.fromPitch p, MIDIEvent.fromVelocity v]
(MIDIEvent.PolyAfter p pr) -> outC 10 [MIDIEvent.fromPitch p, pr]
(MIDIEvent.Control cn cv) -> outC 11 [fromEnum cn, cv]
(MIDIEvent.ProgramChange pn) -> outC 12 [MIDIEvent.fromProgram pn]
(MIDIEvent.MonoAfter pr) -> outC 13 [pr]
(MIDIEvent.PitchBend pb) ->
let (hi,lo) = Bit.splitAt 7 pb in outC 14 [lo,hi]
outChan :: MIDIEvent.Channel -> Int -> [Int] -> MIDIWriter ()
outChan chan code bytes =
do outInt 1 (16*code + MIDIEvent.fromChannel chan)
mapM_ (outInt 1) bytes
outMetaByteStr :: Int -> ByteString -> MIDIWriter ()
outMetaByteStr code bytes =
do
outInt 1 255
outInt 1 code
outVar (genericLength bytes)
outByteStr bytes
outMetaStr :: Int -> String -> MIDIWriter ()
outMetaStr code =
outMetaByteStr code . stringByteFromChar
outMetaList :: Int -> [Int] -> MIDIWriter ()
outMetaList code =
outMetaByteStr code . map fromIntegral
outMetaMW :: Int -> MIDIWriter () -> MIDIWriter ()
outMetaMW code = outMetaByteStr code . execWriter
outputMetaEvent :: MetaEvent -> MIDIWriter ()
outputMetaEvent (SequenceNum num) = outMetaMW 0 (outInt 2 num)
outputMetaEvent (TextEvent s) = outMetaStr 1 s
outputMetaEvent (Copyright s) = outMetaStr 2 s
outputMetaEvent (TrackName s) = outMetaStr 3 s
outputMetaEvent (InstrName s) = outMetaStr 4 s
outputMetaEvent (Lyric s) = outMetaStr 5 s
outputMetaEvent (Marker s) = outMetaStr 6 s
outputMetaEvent (CuePoint s) = outMetaStr 7 s
outputMetaEvent (MIDIPrefix c) = outMetaList 32 [MIDIEvent.fromChannel c]
outputMetaEvent EndOfTrack = outMetaList 47 []
outputMetaEvent (SetTempo tp) = outMetaMW 81 (outInt 3 (NonNeg.toNumber tp))
outputMetaEvent (SMPTEOffset hr mn se fr ff)
= outMetaList 84 [hr,mn,se,fr,ff]
outputMetaEvent (TimeSig n d c b) = outMetaList 88 [n,d,c,b]
outputMetaEvent (KeySig sf mi) = outMetaList 89 [sf', fromEnum mi]
where k = index (KeyCf,KeyCs) sf 7
sf' = if (k >= 0)
then k
else 255+k
outputMetaEvent (SequencerSpecific codes)
= outMetaByteStr 127 codes
outputMetaEvent (Unknown typ s) = outMetaByteStr typ s
type MIDIWriter a = Writer ByteString a
outInt :: Int -> Int -> MIDIWriter ()
outInt a = outByteStr . map fromIntegral . Bit.someBytes a
outStr :: String -> MIDIWriter ()
outStr = outByteStr . stringByteFromChar
outByteStr :: ByteString -> MIDIWriter ()
outByteStr = tell
outVar :: NonNeg.Integer -> MIDIWriter ()
outVar n =
let bytes = map fromIntegral $ Bit.toBase 128 n
in case bytes of
[] -> outInt 1 0
(_:bs) ->
let highBits = map (const 128) bs ++ [0]
in outByteStr (zipWith (.|.) highBits bytes)
outTag :: String -> MIDIWriter ()
outTag tag@(_:_:_:_:[]) = outStr tag
outTag tag =
error ("SaveMIDI.outChunk: Chunk name " ++ tag ++
" does not consist of 4 characters.")
type OutChunk = String -> MIDIWriter () -> MIDIWriter ()
outChunk, outOpenChunk :: OutChunk
outChunk tag m =
do
outTag tag
let str = execWriter m
outInt 4 (length str)
outByteStr str
outOpenChunk tag m =
do
outTag tag
outInt 4 (1)
m