module Sound.MIDI.Writer.Basic where

import qualified Numeric.NonNegative.Wrapper as NonNeg

import qualified Sound.MIDI.Bit as Bit
import Data.Bits ((.|.))
import qualified Sound.MIDI.IO as MIO
import Sound.MIDI.IO (listByteFromChar, )
import Control.Monad.Trans.Writer (Writer, execWriter, tell, )
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, )
import Control.Monad.Trans (lift, )
import Data.List (genericLength, )
import Data.Word (Word8, )
import Data.Char (chr, )

import qualified Data.ByteString.Lazy as B
import qualified Data.Binary as Binary
import Data.Binary.Put (PutM, runPut, putLazyByteString, )

import Control.Exception (bracket, )
import qualified System.IO as IO
import System.IO (openBinaryFile, hClose, hPutChar, Handle, IOMode(WriteMode))
-- import System.IO.Error (ioError, userError)

import Prelude hiding (putStr, )



class Monad m => C m where
   putByte :: Word8 -> m ()
   {- |
   @putLengthBlock n writeBody@
   write @n@ bytes indicating the number of bytes written by @writeBody@
   and then it runs @writeBody@.
   -}
   putLengthBlock :: Int -> m () -> m ()


newtype ByteList a =
   ByteList {unByteList :: Writer MIO.ByteList a}

instance Monad ByteList where
   return = ByteList . return
   x >>= y = ByteList $ unByteList . y =<< unByteList x

instance C ByteList where
   putByte = ByteList . tell . (:[])
   putLengthBlock n writeBody =
      let body = runByteList writeBody
      in  putInt n (length body) >> putByteList body


runByteList :: ByteList () -> MIO.ByteList
runByteList = execWriter . unByteList




newtype ByteString a =
   ByteString {unByteString :: PutM a}

instance Monad ByteString where
   return = ByteString . return
   x >>= y = ByteString $ unByteString . y =<< unByteString x

instance C ByteString where
   putByte = ByteString . Binary.putWord8
   putLengthBlock n writeBody =
      let body = runByteString writeBody
          len = B.length body
          errLen =
             if len >= div (256^n) 2
               then error "Chunk too large"
               else fromIntegral len
      in  putInt n errLen >> ByteString (putLazyByteString body)


runByteString :: ByteString () -> B.ByteString
runByteString = runPut . unByteString




newtype SeekableFile a =
   SeekableFile {unSeekableFile :: ReaderT Handle IO a}

instance Monad SeekableFile where
   return = SeekableFile . return
   x >>= y = SeekableFile $ unSeekableFile . y =<< unSeekableFile x

instance C SeekableFile where
   putByte c =
      SeekableFile $
         ask >>= \h ->
         lift $ hPutChar h (chr $ fromIntegral c)
   putLengthBlock n writeBody =
      SeekableFile $
      ask >>= \h -> lift $
      do lenPos <- IO.hGetPosn h
         IO.hPutStr h (replicate n '\000')
         startPos <- IO.hTell h
         runSeekableHandle h writeBody
         stopPos <- IO.hTell h
         contPos <- IO.hGetPosn h
         IO.hSetPosn lenPos
         let len = stopPos - startPos
         if len >= 2^(31::Int)
           then ioError (userError ("chunk too large, size " ++ show len))
           else runSeekableHandle h (putInt n (fromInteger len))
         IO.hSetPosn contPos


runSeekableFile :: FilePath -> SeekableFile () -> IO ()
runSeekableFile name w =
   bracket
      (openBinaryFile name WriteMode)
      hClose
      (flip runSeekableHandle w)

runSeekableHandle :: Handle -> SeekableFile () -> IO ()
runSeekableHandle h w =
   runReaderT (unSeekableFile w) h




putInt :: C writer => Int -> Int -> writer ()
putInt a = putByteList . map fromIntegral . Bit.someBytes a

putStr :: C writer => String -> writer ()
putStr = putByteList . listByteFromChar

putIntAsByte :: C writer => Int -> writer ()
putIntAsByte x = putByte $ fromIntegral x

putByteList :: C writer => MIO.ByteList -> writer ()
putByteList = mapM_ putByte

putLenByteList :: C writer => MIO.ByteList -> writer ()
putLenByteList bytes =
   do putVar (genericLength bytes)
      putByteList 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.
-}

putVar :: C writer => NonNeg.Integer -> writer ()
putVar n =
   let bytes = map fromIntegral $ Bit.toBase 128 n
   in  case bytes of
          [] -> putInt 1 0
          (_:bs) ->
             let highBits = map (const 128) bs ++ [0]
             in  putByteList (zipWith (.|.) highBits bytes)