{- |
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
   (toFile, toStream, toOpenStream, eventToStream, ) 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)

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

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

{- |
Convert a MIDI file to a ByteString.
-}
toStream :: MIDIFile.T -> ByteString
toStream = execWriter . outMF outChunk

{- |
Convert a MIDI file to a ByteString
while replacing chunk lengths by (-1).
This way writing the file is more lazy.
I don't know whether this is useful for anything,
thus simply don't use it.
-}
{-# DEPRECATED toOpenStream "use toStream instead" #-}
toOpenStream :: MIDIFile.T -> ByteString
toOpenStream = execWriter . outMF outOpenChunk


outMF :: OutChunk -> MIDIFile.T -> MIDIWriter ()
outMF outChk (MIDIFile.Cons mft divisn trks) =
  do
    outChunk "MThd" (do
                       outInt 2 (fromEnum mft) -- format (type 0, 1 or 2)
                       outInt 2 (length trks)  -- number of tracks to come
                       outputDivision divisn)  -- time unit
    mapM_ (outputTrack outChk) trks

outputDivision :: Division -> MIDIWriter ()
outputDivision (Ticks nticks) =
   outInt 2 (NonNeg.toNumber nticks)
outputDivision (SMPTE mode nticks) =
   do
      outInt 1 (256-mode)
      outInt 1 nticks

outputTrack :: OutChunk -> Track -> MIDIWriter ()
outputTrack outChk trk =
   outChk "MTrk" $
   EventList.mapM_ outVar outputEvent $
   EventList.snoc trk 0 (MetaEvent EndOfTrack)


eventToStream :: MIDIFile.Event -> ByteString
eventToStream = execWriter . outputEvent

{- |
The following functions encode various 'MIDIFile.T' elements
into the raw data of a standard MIDI file.
-}

outputEvent :: MIDIFile.Event -> MIDIWriter ()
outputEvent e =
   case e of
      MIDIEvent ch mevent -> outputMIDIEvent ch mevent
      MetaEvent mevent    -> outputMetaEvent mevent
      SysExStart bytes -> outInt 1 240 >> outLenByteStr bytes
      SysExCont  bytes -> outInt 1 247 >> outLenByteStr bytes

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] -- little-endian!!

-- output a channel event
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
      outLenByteStr bytes

outMetaStr :: Int -> String -> MIDIWriter ()
outMetaStr code =
   outMetaByteStr code . stringByteFromChar

outMetaList :: Int -> [Int] -> MIDIWriter ()
outMetaList code =
   outMetaByteStr code . map fromIntegral

-- As with outChunk, there are other ways to do this - but
-- it's not obvious which is best or if performance is a big issue.
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

{- |
The 'MIDIWriter' accumulates a String.
For all the usual reasons, the String is represented by ShowS.
-}

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

outLenByteStr :: ByteString -> MIDIWriter ()
outLenByteStr bytes =
   do outVar (genericLength bytes)
      outByteStr bytes

{- |
Numbers of variable size are represented by sequences of 7-bit blocks
tagged (in the top bit) with a bit indicating:
(1) that more data follows; or
(0) that this is the last block.
-}

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.")

{-
Note: here I've chosen to compute the track twice
rather than store it.  Other options are worth exploring.
-}

type OutChunk = String -> MIDIWriter () -> MIDIWriter ()

outChunk, outOpenChunk :: OutChunk

outChunk tag m =
   do
     outTag tag
     let str = execWriter m
     outInt 4 (length str)
     outByteStr str

{- |
The MIDI standard seems to require a fixed length for all chunks.
Chunks with unknown length are essential for infinite music
and music that is created on the fly.
-}

outOpenChunk tag m =
   do
     outTag tag
     outInt 4 (-1)
     m