{- |
Save MIDI data to files.

The functions in this module allow 'Sound.MIDI.File.T's
to be made 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) 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;
its first argument is the filename:
-}

toFile :: FilePath -> 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'.
-}

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

{- |
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
      _                   -> 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] -- 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
      outVar (genericLength bytes)
      outByteStr 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

{- |
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