module Sound.MIDI.Writer.Basic where

import qualified Numeric.NonNegative.Wrapper as NonNeg

import qualified Sound.MIDI.Bit as Bit
import qualified Sound.MIDI.IO as MIO
import qualified Sound.MIDI.Monoid as M
import qualified Data.Monoid as Monoid

import Data.Bits ((.|.))
import Sound.MIDI.IO (listByteFromChar, )
import Data.Monoid (Monoid, mempty, mappend, mconcat, )
import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, )

import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, )
import Control.Monad.Trans.Class (lift, )

import Data.List (genericLength, )
import Data.Word (Word8, )
import Data.Char (chr, )

import qualified Data.ByteString.Lazy as B
import qualified Data.Binary.Builder as Builder
import Data.Binary.Builder (Builder, fromLazyByteString, )

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


-- differences list
newtype ByteList =
   ByteList {unByteList :: Monoid.Endo MIO.ByteList}

instance Monoid ByteList where
   mempty = ByteList mempty
   mappend = genAppend ByteList unByteList
   mconcat = genConcat ByteList unByteList

instance C ByteList where
   putByte = ByteList . Monoid.Endo . (:)
   putLengthBlock n writeBody =
      let body = runByteList writeBody
      in  putInt n (length body) `mappend`
          putByteListSpec body  -- we could call 'writeBody' but this would recompute the data


-- | 'putByteList' specialised to 'ByteList'
putByteListSpec :: MIO.ByteList -> ByteList
putByteListSpec = ByteList . Monoid.Endo . (++)


runByteList :: ByteList -> MIO.ByteList
runByteList = flip Monoid.appEndo [] . unByteList




newtype ByteString =
   ByteString {unByteString :: Builder}

instance Monoid ByteString where
   mempty = ByteString $ mempty
   mappend = genAppend ByteString unByteString
   mconcat = genConcat ByteString unByteString

instance C ByteString where
   putByte = ByteString . Builder.singleton
   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 (fromLazyByteString body)


runByteString :: ByteString -> B.ByteString
runByteString = Builder.toLazyByteString . unByteString




newtype SeekableFile =
   SeekableFile {unSeekableFile :: ReaderT Handle IO ()}

instance Monoid SeekableFile where
   mempty = SeekableFile $ return ()
   mappend x y = SeekableFile $ unSeekableFile x >> unSeekableFile y
   mconcat xs  = SeekableFile $ mapM_ unSeekableFile xs

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 = M.concatMap putByte

putLenByteList :: C writer => MIO.ByteList -> writer
putLenByteList bytes =
   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)