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 Data.Monoid as Monoid

import Data.Bits ((.|.))
import Sound.MIDI.IO (listByteFromChar, )
import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, nonEmptyConcat, )
import Data.Foldable (foldMap, )
import Data.Monoid (Monoid, mempty, mappend, mconcat, )
import Data.Semigroup (Semigroup(sconcat, (<>)), )

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 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 {ByteList -> Endo ByteList
unByteList :: Monoid.Endo MIO.ByteList}

instance Semigroup ByteList where
   <> :: ByteList -> ByteList -> ByteList
(<>) = (Endo ByteList -> ByteList)
-> (ByteList -> Endo ByteList) -> ByteList -> ByteList -> ByteList
forall m a. Monoid m => (m -> a) -> (a -> m) -> a -> a -> a
genAppend Endo ByteList -> ByteList
ByteList ByteList -> Endo ByteList
unByteList
   sconcat :: NonEmpty ByteList -> ByteList
sconcat = (Endo ByteList -> ByteList)
-> (ByteList -> Endo ByteList) -> NonEmpty ByteList -> ByteList
forall m a. Semigroup m => (m -> a) -> (a -> m) -> NonEmpty a -> a
nonEmptyConcat Endo ByteList -> ByteList
ByteList ByteList -> Endo ByteList
unByteList

instance Monoid ByteList where
   mempty :: ByteList
mempty = Endo ByteList -> ByteList
ByteList Endo ByteList
forall a. Monoid a => a
mempty
   mappend :: ByteList -> ByteList -> ByteList
mappend = (Endo ByteList -> ByteList)
-> (ByteList -> Endo ByteList) -> ByteList -> ByteList -> ByteList
forall m a. Monoid m => (m -> a) -> (a -> m) -> a -> a -> a
genAppend Endo ByteList -> ByteList
ByteList ByteList -> Endo ByteList
unByteList
   mconcat :: [ByteList] -> ByteList
mconcat = (Endo ByteList -> ByteList)
-> (ByteList -> Endo ByteList) -> [ByteList] -> ByteList
forall m a. Monoid m => (m -> a) -> (a -> m) -> [a] -> a
genConcat Endo ByteList -> ByteList
ByteList ByteList -> Endo ByteList
unByteList

instance C ByteList where
   putByte :: Word8 -> ByteList
putByte = Endo ByteList -> ByteList
ByteList (Endo ByteList -> ByteList)
-> (Word8 -> Endo ByteList) -> Word8 -> ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteList -> ByteList) -> Endo ByteList
forall a. (a -> a) -> Endo a
Monoid.Endo ((ByteList -> ByteList) -> Endo ByteList)
-> (Word8 -> ByteList -> ByteList) -> Word8 -> Endo ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)
   putLengthBlock :: Int -> ByteList -> ByteList
putLengthBlock Int
n ByteList
writeBody =
      let body :: ByteList
body = ByteList -> ByteList
runByteList ByteList
writeBody
      in  Int -> Int -> ByteList
forall writer. C writer => Int -> Int -> writer
putInt Int
n (ByteList -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ByteList
body) ByteList -> ByteList -> ByteList
forall a. Monoid a => a -> a -> a
`mappend`
          ByteList -> ByteList
putByteListSpec ByteList
body  -- we could call 'writeBody' but this would recompute the data


-- | 'putByteList' specialised to 'ByteList'
putByteListSpec :: MIO.ByteList -> ByteList
putByteListSpec :: ByteList -> ByteList
putByteListSpec = Endo ByteList -> ByteList
ByteList (Endo ByteList -> ByteList)
-> (ByteList -> Endo ByteList) -> ByteList -> ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteList -> ByteList) -> Endo ByteList
forall a. (a -> a) -> Endo a
Monoid.Endo ((ByteList -> ByteList) -> Endo ByteList)
-> (ByteList -> ByteList -> ByteList) -> ByteList -> Endo ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteList -> ByteList -> ByteList
forall a. [a] -> [a] -> [a]
(++)


runByteList :: ByteList -> MIO.ByteList
runByteList :: ByteList -> ByteList
runByteList = (Endo ByteList -> ByteList -> ByteList)
-> ByteList -> Endo ByteList -> ByteList
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo ByteList -> ByteList -> ByteList
forall a. Endo a -> a -> a
Monoid.appEndo [] (Endo ByteList -> ByteList)
-> (ByteList -> Endo ByteList) -> ByteList -> ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteList -> Endo ByteList
unByteList




newtype ByteString = ByteString {ByteString -> Builder
unByteString :: Builder}

instance Semigroup ByteString where
   <> :: ByteString -> ByteString -> ByteString
(<>) = (Builder -> ByteString)
-> (ByteString -> Builder)
-> ByteString
-> ByteString
-> ByteString
forall m a. Monoid m => (m -> a) -> (a -> m) -> a -> a -> a
genAppend Builder -> ByteString
ByteString ByteString -> Builder
unByteString
   sconcat :: NonEmpty ByteString -> ByteString
sconcat = (Builder -> ByteString)
-> (ByteString -> Builder) -> NonEmpty ByteString -> ByteString
forall m a. Semigroup m => (m -> a) -> (a -> m) -> NonEmpty a -> a
nonEmptyConcat Builder -> ByteString
ByteString ByteString -> Builder
unByteString

instance Monoid ByteString where
   mempty :: ByteString
mempty = Builder -> ByteString
ByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
forall a. Monoid a => a
mempty
   mappend :: ByteString -> ByteString -> ByteString
mappend = (Builder -> ByteString)
-> (ByteString -> Builder)
-> ByteString
-> ByteString
-> ByteString
forall m a. Monoid m => (m -> a) -> (a -> m) -> a -> a -> a
genAppend Builder -> ByteString
ByteString ByteString -> Builder
unByteString
   mconcat :: [ByteString] -> ByteString
mconcat = (Builder -> ByteString)
-> (ByteString -> Builder) -> [ByteString] -> ByteString
forall m a. Monoid m => (m -> a) -> (a -> m) -> [a] -> a
genConcat Builder -> ByteString
ByteString ByteString -> Builder
unByteString

instance C ByteString where
   putByte :: Word8 -> ByteString
putByte = Builder -> ByteString
ByteString (Builder -> ByteString)
-> (Word8 -> Builder) -> Word8 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Builder
Builder.singleton
   putLengthBlock :: Int -> ByteString -> ByteString
putLengthBlock Int
n ByteString
writeBody =
      let body :: ByteString
body = ByteString -> ByteString
runByteString ByteString
writeBody
          len :: Int64
len = ByteString -> Int64
B.length ByteString
body
          errLen :: Int
errLen =
             if Int64
len Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
div (Int64
256Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n) Int64
2
               then [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"Chunk too large"
               else Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
      in  Int -> Int -> ByteString
forall writer. C writer => Int -> Int -> writer
putInt Int
n Int
errLen ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+#+ Builder -> ByteString
ByteString (ByteString -> Builder
fromLazyByteString ByteString
body)


runByteString :: ByteString -> B.ByteString
runByteString :: ByteString -> ByteString
runByteString = Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
unByteString




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

instance Semigroup SeekableFile where
   SeekableFile
x <> :: SeekableFile -> SeekableFile -> SeekableFile
<> SeekableFile
y = ReaderT Handle IO () -> SeekableFile
SeekableFile (ReaderT Handle IO () -> SeekableFile)
-> ReaderT Handle IO () -> SeekableFile
forall a b. (a -> b) -> a -> b
$ SeekableFile -> ReaderT Handle IO ()
unSeekableFile SeekableFile
x ReaderT Handle IO ()
-> ReaderT Handle IO () -> ReaderT Handle IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SeekableFile -> ReaderT Handle IO ()
unSeekableFile SeekableFile
y

instance Monoid SeekableFile where
   mempty :: SeekableFile
mempty = ReaderT Handle IO () -> SeekableFile
SeekableFile (ReaderT Handle IO () -> SeekableFile)
-> ReaderT Handle IO () -> SeekableFile
forall a b. (a -> b) -> a -> b
$ () -> ReaderT Handle IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   mappend :: SeekableFile -> SeekableFile -> SeekableFile
mappend = SeekableFile -> SeekableFile -> SeekableFile
forall a. Semigroup a => a -> a -> a
(<>)
   mconcat :: [SeekableFile] -> SeekableFile
mconcat = ReaderT Handle IO () -> SeekableFile
SeekableFile (ReaderT Handle IO () -> SeekableFile)
-> ([SeekableFile] -> ReaderT Handle IO ())
-> [SeekableFile]
-> SeekableFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SeekableFile -> ReaderT Handle IO ())
-> [SeekableFile] -> ReaderT Handle IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SeekableFile -> ReaderT Handle IO ()
unSeekableFile

instance C SeekableFile where
   putByte :: Word8 -> SeekableFile
putByte Word8
c =
      ReaderT Handle IO () -> SeekableFile
SeekableFile (ReaderT Handle IO () -> SeekableFile)
-> ReaderT Handle IO () -> SeekableFile
forall a b. (a -> b) -> a -> b
$
         ReaderT Handle IO Handle
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Handle IO Handle
-> (Handle -> ReaderT Handle IO ()) -> ReaderT Handle IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h ->
         IO () -> ReaderT Handle IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Handle IO ()) -> IO () -> ReaderT Handle IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Char -> IO ()
hPutChar Handle
h (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c)
   putLengthBlock :: Int -> SeekableFile -> SeekableFile
putLengthBlock Int
n SeekableFile
writeBody =
      ReaderT Handle IO () -> SeekableFile
SeekableFile (ReaderT Handle IO () -> SeekableFile)
-> ReaderT Handle IO () -> SeekableFile
forall a b. (a -> b) -> a -> b
$
      ReaderT Handle IO Handle
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Handle IO Handle
-> (Handle -> ReaderT Handle IO ()) -> ReaderT Handle IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> IO () -> ReaderT Handle IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Handle IO ()) -> IO () -> ReaderT Handle IO ()
forall a b. (a -> b) -> a -> b
$
      do HandlePosn
lenPos <- Handle -> IO HandlePosn
IO.hGetPosn Handle
h
         Handle -> [Char] -> IO ()
IO.hPutStr Handle
h (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
n Char
'\000')
         Integer
startPos <- Handle -> IO Integer
IO.hTell Handle
h
         Handle -> SeekableFile -> IO ()
runSeekableHandle Handle
h SeekableFile
writeBody
         Integer
stopPos <- Handle -> IO Integer
IO.hTell Handle
h
         HandlePosn
contPos <- Handle -> IO HandlePosn
IO.hGetPosn Handle
h
         HandlePosn -> IO ()
IO.hSetPosn HandlePosn
lenPos
         let len :: Integer
len = Integer
stopPos Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
startPos
         if Integer
len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
31::Int)
           then IOError -> IO ()
forall a. IOError -> IO a
ioError ([Char] -> IOError
userError ([Char]
"chunk too large, size " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
len))
           else Handle -> SeekableFile -> IO ()
runSeekableHandle Handle
h (Int -> Int -> SeekableFile
forall writer. C writer => Int -> Int -> writer
putInt Int
n (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
len))
         HandlePosn -> IO ()
IO.hSetPosn HandlePosn
contPos


runSeekableFile :: FilePath -> SeekableFile -> IO ()
runSeekableFile :: [Char] -> SeekableFile -> IO ()
runSeekableFile [Char]
name SeekableFile
w =
   IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      ([Char] -> IOMode -> IO Handle
openBinaryFile [Char]
name IOMode
WriteMode)
      Handle -> IO ()
hClose
      ((Handle -> SeekableFile -> IO ())
-> SeekableFile -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> SeekableFile -> IO ()
runSeekableHandle SeekableFile
w)

runSeekableHandle :: Handle -> SeekableFile -> IO ()
runSeekableHandle :: Handle -> SeekableFile -> IO ()
runSeekableHandle Handle
h SeekableFile
w =
   ReaderT Handle IO () -> Handle -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SeekableFile -> ReaderT Handle IO ()
unSeekableFile SeekableFile
w) Handle
h




putInt :: C writer => Int -> Int -> writer
putInt :: Int -> Int -> writer
putInt Int
a = ByteList -> writer
forall writer. C writer => ByteList -> writer
putByteList (ByteList -> writer) -> (Int -> ByteList) -> Int -> writer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Word8) -> ByteList -> ByteList
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteList -> ByteList) -> (Int -> ByteList) -> Int -> ByteList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> ByteList
forall a. Integral a => Int -> a -> ByteList
Bit.someBytes Int
a

putStr :: C writer => String -> writer
putStr :: [Char] -> writer
putStr = ByteList -> writer
forall writer. C writer => ByteList -> writer
putByteList (ByteList -> writer) -> ([Char] -> ByteList) -> [Char] -> writer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteList
listByteFromChar

putIntAsByte :: C writer => Int -> writer
putIntAsByte :: Int -> writer
putIntAsByte Int
x = Word8 -> writer
forall m. C m => Word8 -> m
putByte (Word8 -> writer) -> Word8 -> writer
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x

putByteList :: C writer => MIO.ByteList -> writer
putByteList :: ByteList -> writer
putByteList = (Word8 -> writer) -> ByteList -> writer
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word8 -> writer
forall m. C m => Word8 -> m
putByte

putLenByteList :: C writer => MIO.ByteList -> writer
putLenByteList :: ByteList -> writer
putLenByteList ByteList
bytes =
   Integer -> writer
forall writer. C writer => Integer -> writer
putVar (ByteList -> Integer
forall i a. Num i => [a] -> i
genericLength ByteList
bytes) writer -> writer -> writer
forall a. Monoid a => a -> a -> a
+#+
   ByteList -> writer
forall writer. C writer => ByteList -> writer
putByteList ByteList
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 :: Integer -> writer
putVar Integer
n =
   let bytes :: ByteList
bytes = (Integer -> Word8) -> [Integer] -> ByteList
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Integer] -> ByteList) -> [Integer] -> ByteList
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> [Integer]
forall a. Integral a => a -> a -> [a]
Bit.toBase Integer
128 Integer
n
   in  case ByteList
bytes of
          [] -> Int -> Int -> writer
forall writer. C writer => Int -> Int -> writer
putInt Int
1 Int
0
          (Word8
_:ByteList
bs) ->
             let highBits :: ByteList
highBits = (Word8 -> Word8) -> ByteList -> ByteList
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Word8 -> Word8
forall a b. a -> b -> a
const Word8
128) ByteList
bs ByteList -> ByteList -> ByteList
forall a. [a] -> [a] -> [a]
++ [Word8
0]
             in  ByteList -> writer
forall writer. C writer => ByteList -> writer
putByteList ((Word8 -> Word8 -> Word8) -> ByteList -> ByteList -> ByteList
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
(.|.) ByteList
highBits ByteList
bytes)