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
(<>) = 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 = 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 forall a. Monoid a => a
mempty
   mappend :: ByteList -> ByteList -> ByteList
mappend = 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> Endo a
Monoid.Endo 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  forall writer. C writer => Int -> Int -> writer
putInt Int
n (forall (t :: * -> *) a. Foldable t => t a -> Int
length ByteList
body) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> Endo a
Monoid.Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++)


runByteList :: ByteList -> MIO.ByteList
runByteList :: ByteList -> ByteList
runByteList = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Endo a -> a -> a
Monoid.appEndo [] 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
(<>) = forall m a. Monoid m => (m -> a) -> (a -> m) -> a -> a -> a
genAppend Builder -> ByteString
ByteString ByteString -> Builder
unByteString
   sconcat :: NonEmpty ByteString -> ByteString
sconcat = 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 forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
   mappend :: ByteString -> ByteString -> ByteString
mappend = forall m a. Monoid m => (m -> a) -> (a -> m) -> a -> a -> a
genAppend Builder -> ByteString
ByteString ByteString -> Builder
unByteString
   mconcat :: [ByteString] -> ByteString
mconcat = 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 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 forall a. Ord a => a -> a -> Bool
>= forall a. Integral a => a -> a -> a
div (Int64
256forall a b. (Num a, Integral b) => a -> b -> a
^Int
n) Int64
2
               then forall a. HasCallStack => [Char] -> a
error [Char]
"Chunk too large"
               else forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
      in  forall writer. C writer => Int -> Int -> writer
putInt Int
n Int
errLen 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 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 forall a b. (a -> b) -> a -> b
$ SeekableFile -> ReaderT Handle IO ()
unSeekableFile SeekableFile
x 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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
   mappend :: SeekableFile -> SeekableFile -> SeekableFile
mappend = forall a. Semigroup a => a -> a -> a
(<>)
   mconcat :: [SeekableFile] -> SeekableFile
mconcat = ReaderT Handle IO () -> SeekableFile
SeekableFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$
         forall (m :: * -> *) r. Monad m => ReaderT r m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h ->
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Handle -> Char -> IO ()
hPutChar Handle
h (Int -> Char
chr forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) r. Monad m => ReaderT r m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Handle
h -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
      do HandlePosn
lenPos <- Handle -> IO HandlePosn
IO.hGetPosn Handle
h
         Handle -> [Char] -> IO ()
IO.hPutStr Handle
h (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 forall a. Num a => a -> a -> a
- Integer
startPos
         if Integer
len forall a. Ord a => a -> a -> Bool
>= Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
31::Int)
           then forall a. IOError -> IO a
ioError ([Char] -> IOError
userError ([Char]
"chunk too large, size " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Integer
len))
           else Handle -> SeekableFile -> IO ()
runSeekableHandle Handle
h (forall writer. C writer => Int -> Int -> writer
putInt Int
n (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 =
   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
      (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 =
   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 :: forall writer. C writer => Int -> Int -> writer
putInt Int
a = forall writer. C writer => ByteList -> writer
putByteList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Int -> a -> ByteList
Bit.someBytes Int
a

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

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

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

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