module Sound.MIDI.File.Save
(toSeekableFile, toFile, toByteList, toByteString,
toCompressedByteString, ) where
import Sound.MIDI.File
import qualified Sound.MIDI.File as MIDIFile
import qualified Sound.MIDI.File.Event as Event
import qualified Sound.MIDI.File.Event.Meta as MetaEvent
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg
import qualified Sound.MIDI.Writer.Status as StatusWriter
import qualified Sound.MIDI.Writer.Basic as Writer
import Control.Monad.Reader (ask, )
import Control.Monad.Trans (lift, )
import Sound.MIDI.IO (ByteList, writeBinaryFile, )
import qualified Data.ByteString.Lazy as B
toSeekableFile :: FilePath -> MIDIFile.T -> IO ()
toSeekableFile fn =
Writer.runSeekableFile fn . StatusWriter.toWriterWithoutStatus . put
toFile :: FilePath -> MIDIFile.T -> IO ()
toFile fn mf = writeBinaryFile fn (toByteList mf)
toByteList :: MIDIFile.T -> ByteList
toByteList =
Writer.runByteList . StatusWriter.toWriterWithoutStatus . put
toByteString :: MIDIFile.T -> B.ByteString
toByteString =
Writer.runByteString . StatusWriter.toWriterWithoutStatus . put
toCompressedByteString :: MIDIFile.T -> B.ByteString
toCompressedByteString =
Writer.runByteString . StatusWriter.toWriterWithStatus . put .
MIDIFile.implicitNoteOff
put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer ()
put (MIDIFile.Cons mft divisn trks) =
do
putChunk "MThd" $ lift $
do
Writer.putInt 2 (fromEnum mft)
Writer.putInt 2 (length trks)
putDivision divisn
mapM_ putTrack trks
putDivision :: Writer.C writer => Division -> writer ()
putDivision (Ticks nticks) =
Writer.putInt 2 (NonNeg.toNumber nticks)
putDivision (SMPTE mode nticks) =
do
Writer.putIntAsByte (256mode)
Writer.putIntAsByte nticks
putTrack :: Writer.C writer => Track -> StatusWriter.T writer ()
putTrack trk =
putChunk "MTrk" $
EventList.mapM_ (lift . Writer.putVar) Event.put $
EventList.snoc trk 0 (Event.MetaEvent MetaEvent.EndOfTrack)
putChunk :: Writer.C writer =>
String -> StatusWriter.T writer () -> StatusWriter.T writer ()
putChunk tag m =
do
lift $ putTag tag
compress <- StatusWriter.Cons ask
lift $ Writer.putLengthBlock 4 $
StatusWriter.toWriter compress m
putTag :: Writer.C writer => String -> writer ()
putTag tag@(_:_:_:_:[]) = Writer.putStr tag
putTag tag =
error ("SaveMIDI.putChunk: Chunk name " ++ tag ++
" does not consist of 4 characters.")