{- |
Save MIDI data to files.

The functions in this module allow 'Sound.MIDI.File.T's
to be written into Standard MIDI files (@*.mid@)
that can be read and played by music programs such as Cakewalk.
-}

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 Sound.MIDI.Monoid ((+#+))

import qualified Data.Monoid.Transformer as Trans
import Data.Foldable (foldMap, )

import Sound.MIDI.IO (ByteList, writeBinaryFile, )

import qualified Data.ByteString.Lazy as B



{- |
Directly write to a file.
Since chunks lengths are not known before writing,
we need to seek in a file.
Thus you cannot write to pipes with this function.
-}
toSeekableFile :: FilePath {- ^ file name -} -> MIDIFile.T -> IO ()
toSeekableFile :: FilePath -> T -> IO ()
toSeekableFile FilePath
fn =
   FilePath -> SeekableFile -> IO ()
Writer.runSeekableFile FilePath
fn (SeekableFile -> IO ()) -> (T -> SeekableFile) -> T -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Uncompressed SeekableFile -> SeekableFile
forall writer. Monoid writer => T Uncompressed writer -> writer
StatusWriter.toWriterWithoutStatus (T Uncompressed SeekableFile -> SeekableFile)
-> (T -> T Uncompressed SeekableFile) -> T -> SeekableFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> T Uncompressed SeekableFile
forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
put

{- |
The function 'toFile' is the main function
for writing 'MIDIFile.T' values to an actual file.
-}
toFile :: FilePath {- ^ file name -} -> MIDIFile.T -> IO ()
toFile :: FilePath -> T -> IO ()
toFile FilePath
fn T
mf = FilePath -> ByteList -> IO ()
writeBinaryFile FilePath
fn (T -> ByteList
toByteList T
mf)

{-
MIDI files are first converted to a monadic string computation
using the function 'put',
and then \"executed\" using 'execWriter'.
-}

{- |
Convert a MIDI file to a 'ByteList'.
-}
toByteList :: MIDIFile.T -> ByteList
toByteList :: T -> ByteList
toByteList =
   ByteList -> ByteList
Writer.runByteList (ByteList -> ByteList) -> (T -> ByteList) -> T -> ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Uncompressed ByteList -> ByteList
forall writer. Monoid writer => T Uncompressed writer -> writer
StatusWriter.toWriterWithoutStatus (T Uncompressed ByteList -> ByteList)
-> (T -> T Uncompressed ByteList) -> T -> ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> T Uncompressed ByteList
forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
put

{- |
Convert a MIDI file to a lazy 'B.ByteString'.
-}
toByteString :: MIDIFile.T -> B.ByteString
toByteString :: T -> ByteString
toByteString =
   ByteString -> ByteString
Writer.runByteString (ByteString -> ByteString) -> (T -> ByteString) -> T -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Uncompressed ByteString -> ByteString
forall writer. Monoid writer => T Uncompressed writer -> writer
StatusWriter.toWriterWithoutStatus (T Uncompressed ByteString -> ByteString)
-> (T -> T Uncompressed ByteString) -> T -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> T Uncompressed ByteString
forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
put

{- |
Convert a MIDI file to a lazy 'B.ByteString'.
It converts @NoteOff p 64@ to @NoteOn p 0@
and then uses the running MIDI status in order to compress the file.
-}
toCompressedByteString :: MIDIFile.T -> B.ByteString
toCompressedByteString :: T -> ByteString
toCompressedByteString =
   ByteString -> ByteString
Writer.runByteString (ByteString -> ByteString) -> (T -> ByteString) -> T -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Compressed ByteString -> ByteString
forall writer. Monoid writer => T Compressed writer -> writer
StatusWriter.toWriterWithStatus (T Compressed ByteString -> ByteString)
-> (T -> T Compressed ByteString) -> T -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> T Compressed ByteString
forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
put (T -> T Compressed ByteString)
-> (T -> T) -> T -> T Compressed ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   T -> T
MIDIFile.implicitNoteOff




put ::
   (StatusWriter.Compression compress, Writer.C writer) =>
   MIDIFile.T -> StatusWriter.T compress writer
put :: T -> T compress writer
put (MIDIFile.Cons Type
mft Division
divisn [Track]
trks) =
   (FilePath -> T compress writer -> T compress writer
forall compress writer.
(Compression compress, C writer) =>
FilePath -> T compress writer -> T compress writer
putChunk FilePath
"MThd" (T compress writer -> T compress writer)
-> T compress writer -> T compress writer
forall a b. (a -> b) -> a -> b
$ writer -> T compress writer
forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
StatusWriter.lift (writer -> T compress writer) -> writer -> T compress writer
forall a b. (a -> b) -> a -> b
$
      Int -> Int -> writer
forall writer. C writer => Int -> Int -> writer
Writer.putInt Int
2 (Type -> Int
forall a. Enum a => a -> Int
fromEnum Type
mft) writer -> writer -> writer
forall m. Monoid m => m -> m -> m
+#+ -- format (type 0, 1 or 2)
      Int -> Int -> writer
forall writer. C writer => Int -> Int -> writer
Writer.putInt Int
2 ([Track] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Track]
trks)  writer -> writer -> writer
forall m. Monoid m => m -> m -> m
+#+ -- number of tracks to come
      Division -> writer
forall writer. C writer => Division -> writer
putDivision Division
divisn)                 -- time unit
   T compress writer -> T compress writer -> T compress writer
forall m. Monoid m => m -> m -> m
+#+ (Track -> T compress writer) -> [Track] -> T compress writer
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Track -> T compress writer
forall compress writer.
(Compression compress, C writer) =>
Track -> T compress writer
putTrack [Track]
trks

putDivision :: Writer.C writer => Division -> writer
putDivision :: Division -> writer
putDivision (Ticks Tempo
nticks) =
   Int -> Int -> writer
forall writer. C writer => Int -> Int -> writer
Writer.putInt Int
2 (Tempo -> Int
forall a. T a -> a
NonNeg.toNumber Tempo
nticks)
putDivision (SMPTE Int
mode Int
nticks) =
   Int -> writer
forall writer. C writer => Int -> writer
Writer.putIntAsByte (Int
256Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
mode) writer -> writer -> writer
forall m. Monoid m => m -> m -> m
+#+
   Int -> writer
forall writer. C writer => Int -> writer
Writer.putIntAsByte Int
nticks

putTrack ::
   (StatusWriter.Compression compress, Writer.C writer) =>
   Track -> StatusWriter.T compress writer
putTrack :: Track -> T compress writer
putTrack Track
trk =
   FilePath -> T compress writer -> T compress writer
forall compress writer.
(Compression compress, C writer) =>
FilePath -> T compress writer -> T compress writer
putChunk FilePath
"MTrk" (T compress writer -> T compress writer)
-> T compress writer -> T compress writer
forall a b. (a -> b) -> a -> b
$
   (Integer -> T compress writer)
-> (T -> T compress writer) -> Track -> T compress writer
forall m time body.
Monoid m =>
(time -> m) -> (body -> m) -> T time body -> m
EventList.concatMapMonoid (writer -> T compress writer
forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
StatusWriter.lift (writer -> T compress writer)
-> (Integer -> writer) -> Integer -> T compress writer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> writer
forall writer. C writer => Integer -> writer
Writer.putVar) T -> T compress writer
forall compress writer.
(Compression compress, C writer) =>
T -> T compress writer
Event.put (Track -> T compress writer) -> Track -> T compress writer
forall a b. (a -> b) -> a -> b
$
   Track -> Integer -> T -> Track
forall time body. T time body -> time -> body -> T time body
EventList.snoc Track
trk Integer
0 (T -> T
Event.MetaEvent T
MetaEvent.EndOfTrack)



putChunk ::
   (StatusWriter.Compression compress, Writer.C writer) =>
   String -> StatusWriter.T compress writer -> StatusWriter.T compress writer
putChunk :: FilePath -> T compress writer -> T compress writer
putChunk FilePath
tag T compress writer
m =
   writer -> T compress writer
forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
StatusWriter.lift (FilePath -> writer
forall writer. C writer => FilePath -> writer
putTag FilePath
tag) T compress writer -> T compress writer -> T compress writer
forall m. Monoid m => m -> m -> m
+#+
   (T compress writer -> T compress writer
forall compress writer. T compress writer -> T compress writer
StatusWriter.Cons (T compress writer -> T compress writer)
-> T compress writer -> T compress writer
forall a b. (a -> b) -> a -> b
$ writer -> T compress writer
forall (t :: * -> *) m. (C t, Monoid m) => m -> t m
Trans.lift (writer -> T compress writer) -> writer -> T compress writer
forall a b. (a -> b) -> a -> b
$
    Int -> writer -> writer
forall m. C m => Int -> m -> m
Writer.putLengthBlock Int
4 (writer -> writer) -> writer -> writer
forall a b. (a -> b) -> a -> b
$ T compress writer -> writer
forall compress writer.
(Compression compress, Monoid writer) =>
T compress writer -> writer
StatusWriter.toWriter T compress writer
m)


putTag :: Writer.C writer => String -> writer
putTag :: FilePath -> writer
putTag tag :: FilePath
tag@(Char
_:Char
_:Char
_:Char
_:[]) = FilePath -> writer
forall writer. C writer => FilePath -> writer
Writer.putStr FilePath
tag
putTag FilePath
tag =
   FilePath -> writer
forall a. HasCallStack => FilePath -> a
error (FilePath
"SaveMIDI.putChunk: Chunk name " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tag FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
          FilePath
" does not consist of 4 characters.")