module Sound.MikMod.MReader where
import Foreign
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal (allocaBytes)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Internal (toForeignPtr, memcpy)
import System.IO
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.Functor ((<$>))
import Control.Monad (when, unless)
import Control.Exception (finally, try)
import Sound.MikMod.Synonyms
import Sound.MikMod.Types
data MREADER
type SeekFn = Ptr () -> CLong -> CInt -> IO CInt
type TellFn = Ptr () -> IO CInt
type ReadFn = Ptr () -> Ptr Word8 -> CSize -> IO BOOL
type GetFn = Ptr () -> IO CInt
type EofFn = Ptr () -> IO BOOL
foreign import ccall "wrapper" mkSeek :: SeekFn -> IO (FunPtr SeekFn)
foreign import ccall "wrapper" mkTell :: TellFn -> IO (FunPtr TellFn)
foreign import ccall "wrapper" mkRead :: ReadFn -> IO (FunPtr ReadFn)
foreign import ccall "wrapper" mkGet :: GetFn -> IO (FunPtr GetFn)
foreign import ccall "wrapper" mkEof :: EofFn -> IO (FunPtr EofFn)
genericEof :: Num a => a
genericEof = (1)
unmarshalSeekMode :: CInt -> SeekMode
unmarshalSeekMode n = case n of
(0) -> AbsoluteSeek
(1) -> RelativeSeek
(2) -> SeekFromEnd
makeSeek :: (Int -> SeekMode -> IO Outcome) -> (Ptr () -> CLong -> CInt -> IO CInt)
makeSeek act _ offset whence = do
outcome <- act (fromIntegral offset) (unmarshalSeekMode whence)
case outcome of
Ok -> return 0
Fail -> return (1)
makeTell :: IO Int -> (Ptr () -> IO CInt)
makeTell act _ = fromIntegral <$> act
makeRead :: (Int -> IO (Maybe ByteString)) -> (Ptr () -> Ptr Word8 -> CSize -> IO BOOL)
makeRead act _ dest csize = do
let len = fromIntegral csize
result <- act (fromIntegral len)
case result of
Nothing -> return 0
Just bs -> do
unsafeWriteByteStringToMemoryLocation (BS.take len bs) dest
return 1
makeGet :: IO (Maybe Word8) -> (Ptr () -> IO CInt)
makeGet act _ = maybe genericEof fromIntegral <$> act
makeEof :: IO IsEOF -> (Ptr () -> IO BOOL)
makeEof act _ = do
eof <- act
case eof of
EOF -> return 1
NotEOF -> return 0
withMReader :: MReader -> (Ptr MREADER -> IO a) -> IO a
withMReader mr action = allocaBytes ((56)) $ \ptr -> do
fp1 <- mkSeek . makeSeek . readerSeek $ mr
fp2 <- mkTell . makeTell . readerTell $ mr
fp3 <- mkRead . makeRead . readerRead $ mr
fp4 <- mkGet . makeGet . readerGet $ mr
fp5 <- mkEof . makeEof . readerEof $ mr
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr fp1
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr fp2
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr fp3
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr fp4
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) ptr fp5
finally (action ptr) $ do
freeHaskellFunPtr fp1
freeHaskellFunPtr fp2
freeHaskellFunPtr fp3
freeHaskellFunPtr fp4
freeHaskellFunPtr fp5
byteStringReader :: ByteString -> IORef Int -> MReader
byteStringReader bs rpos = let len = BS.length bs in MReader
{ readerSeek = \n whence -> do
case whence of
AbsoluteSeek -> writeIORef rpos n
RelativeSeek -> modifyIORef rpos (+n)
SeekFromEnd -> writeIORef rpos (len n)
return Ok
, readerTell = readIORef rpos
, readerRead = \n -> do
i <- readIORef rpos
let i' = min (i+n) len
let m = i' i
if i < len
then do
writeIORef rpos i'
(return . Just . BS.take m . BS.drop i) bs
else return (Just BS.empty)
, readerGet = do
i <- readIORef rpos
if (i >= 0 && i < len)
then do
modifyIORef rpos (+1)
(return . Just . fromIntegral) (BS.index bs i)
else return Nothing
, readerEof = do
i <- readIORef rpos
if (i >= 0 && i < len)
then return NotEOF
else return EOF
}
handleReader :: Handle -> MReader
handleReader h = MReader
{ readerSeek = \n whence -> do
result <- try (hSeek h whence (fromIntegral n)) :: IO (Either IOError ())
case result of
Left _ -> return Fail
Right _ -> return Ok
, readerTell = fromIntegral <$> hTell h
, readerRead = \n -> do
result <- try (BS.hGet h n) :: IO (Either IOError ByteString)
case result of
Left _ -> return Nothing
Right bs -> return (Just bs)
, readerGet = do
bs <- BS.hGet h 1
if BS.null bs
then return Nothing
else (return . Just . fromIntegral . BS.head) bs
, readerEof = do
b <- hIsEOF h
case b of
True -> return EOF
False -> return NotEOF
}
unsafeWriteByteStringToMemoryLocation :: ByteString -> Ptr Word8 -> IO ()
unsafeWriteByteStringToMemoryLocation bs dest =
unless (BS.null bs) $ do
let (fptr, offset, len) = toForeignPtr bs
withForeignPtr fptr
(\ptr -> memcpy dest (ptr `plusPtr` offset) (fromIntegral len))