Interface.chs

{-# LANGUAGE ForeignFunctionInterface #-}
module Sound.File.Sndfile.Interface where

import C2HS
import Control.Monad							(liftM, when)
import Data.Bits								((.|.), (.&.))
import qualified Sound.File.Sndfile.Exception	as E
import System.IO.Unsafe							(unsafePerformIO)

#include <sndfile.h>

{#context lib="libsndfile" prefix="sf"#}

-- ====================================================================
-- Basic types

-- | Type for expressing sample counts.
type Count = Int

-- | Type for expressing sample indices.
type Index = Int

-- ====================================================================
-- Format

-- | Header format.
{#enum HeaderFormat {underscoreToCase} deriving (Eq, Show)#}
#c
enum HeaderFormat
{
    HEADER_FORMAT_NONE  = 0,

    HEADER_FORMAT_WAV   = SF_FORMAT_WAV,
    HEADER_FORMAT_AIFF  = SF_FORMAT_AIFF,
    HEADER_FORMAT_AU    = SF_FORMAT_AU,
    HEADER_FORMAT_RAW   = SF_FORMAT_RAW,
    HEADER_FORMAT_PAF   = SF_FORMAT_PAF,
    HEADER_FORMAT_SVX   = SF_FORMAT_SVX,
    HEADER_FORMAT_NIST  = SF_FORMAT_NIST,
    HEADER_FORMAT_VOC   = SF_FORMAT_VOC,
    HEADER_FORMAT_IRCAM = SF_FORMAT_IRCAM,
    HEADER_FORMAT_W64   = SF_FORMAT_W64,
    HEADER_FORMAT_MAT4  = SF_FORMAT_MAT4,
    HEADER_FORMAT_MAT5  = SF_FORMAT_MAT5,
    HEADER_FORMAT_PVF   = SF_FORMAT_PVF,
    HEADER_FORMAT_XI    = SF_FORMAT_XI,
    HEADER_FORMAT_HTK   = SF_FORMAT_HTK,
    HEADER_FORMAT_SDS   = SF_FORMAT_SDS,
    HEADER_FORMAT_AVR   = SF_FORMAT_AVR,
    HEADER_FORMAT_WAVEX = SF_FORMAT_WAVEX,
    HEADER_FORMAT_SD2   = SF_FORMAT_SD2,
    HEADER_FORMAT_FLAC  = SF_FORMAT_FLAC,
    HEADER_FORMAT_CAF   = SF_FORMAT_CAF
};
#endc

-- | Sample format.
{#enum SampleFormat {underscoreToCase} deriving (Eq, Show)#}
#c
enum SampleFormat
{
    SAMPLE_FORMAT_NONE              = 0,

    SAMPLE_FORMAT_PCM_S8            = SF_FORMAT_PCM_S8,
    SAMPLE_FORMAT_PCM_16            = SF_FORMAT_PCM_16,
    SAMPLE_FORMAT_PCM_24            = SF_FORMAT_PCM_24,
    SAMPLE_FORMAT_PCM_32            = SF_FORMAT_PCM_32,
                                    
    SAMPLE_FORMAT_PCM_U8            = SF_FORMAT_PCM_U8,
                                    
    SAMPLE_FORMAT_FLOAT             = SF_FORMAT_FLOAT,
    SAMPLE_FORMAT_DOUBLE            = SF_FORMAT_DOUBLE,
                                    
    SAMPLE_FORMAT_ULAW              = SF_FORMAT_ULAW,
    SAMPLE_FORMAT_ALAW              = SF_FORMAT_ALAW,
    SAMPLE_FORMAT_IMA_ADPCM         = SF_FORMAT_IMA_ADPCM,
    SAMPLE_FORMAT_MS_ADPCM          = SF_FORMAT_MS_ADPCM,
                                    
    SAMPLE_FORMAT_GSM610            = SF_FORMAT_GSM610,
    SAMPLE_FORMAT_VOX_ADPCM         = SF_FORMAT_VOX_ADPCM,
                                    
    SAMPLE_FORMAT_G721_32           = SF_FORMAT_G721_32,
    SAMPLE_FORMAT_G723_24           = SF_FORMAT_G723_24,
    SAMPLE_FORMAT_G723_40           = SF_FORMAT_G723_40,
                                    
    SAMPLE_FORMAT_DWVW_12           = SF_FORMAT_DWVW_12,
    SAMPLE_FORMAT_DWVW_16           = SF_FORMAT_DWVW_16,
    SAMPLE_FORMAT_DWVW_24           = SF_FORMAT_DWVW_24,
    SAMPLE_FORMAT_DWVW_N            = SF_FORMAT_DWVW_N,
                             
    SAMPLE_FORMAT_FORMAT_DPCM_8     = SF_FORMAT_DPCM_8,
    SAMPLE_FORMAT_FORMAT_DPCM_16    = SF_FORMAT_DPCM_16
};
#endc

-- | Endianness.
{#enum EndianFormat {underscoreToCase} deriving (Eq, Show)#}
#c
enum EndianFormat
{
    ENDIAN_FILE     = SF_ENDIAN_FILE,
    ENDIAN_LITTLE   = SF_ENDIAN_LITTLE,
    ENDIAN_BIG      = SF_ENDIAN_BIG,
    ENDIAN_CPU      = SF_ENDIAN_CPU
};
#endc

-- only used internally
{#enum FormatMask {underscoreToCase} deriving (Eq)#}
#c
enum FormatMask
{
    FORMAT_SUB_MASK     = SF_FORMAT_SUBMASK,
    FORMAT_TYPE_MASK    = SF_FORMAT_TYPEMASK,
    FORMAT_END_MASK     = SF_FORMAT_ENDMASK
};
#endc

-- |Stream format specification, consisting of header, sample and endianness formats.
--
-- Not all combinations of header, sample and endianness formats are valid; valid combinamtions can be checked with the 'checkFormat' function.
data Format = Format {
    headerFormat :: HeaderFormat,
    sampleFormat :: SampleFormat,
    endianFormat :: EndianFormat
} deriving (Eq, Show)

-- |Default \'empty\' format, useful when opening files for reading with 'ReadMode'.
defaultFormat :: Format
defaultFormat = Format HeaderFormatNone SampleFormatNone EndianFile

-- Convert CInt to Format
hsFormat :: CInt -> Format
hsFormat i =
   let hf = cToEnum (i .&. (cFromEnum FormatTypeMask) .&. complement (cFromEnum FormatEndMask))
       sf = cToEnum (i .&. (cFromEnum FormatSubMask))
       ef = cToEnum (i .&. (cFromEnum FormatEndMask))
   in
       Format {
           headerFormat = hf,
           sampleFormat = sf,
           endianFormat = ef
       }

-- Convert Format to CInt
cFormat :: Format -> CInt
cFormat (Format hf sf ef) = (cFromEnum hf) .|. (cFromEnum sf) .|. (cFromEnum ef)

-- ====================================================================
-- Info

-- |The 'Info' structure is for passing data between the calling function and the library when opening a stream for reading or writing.
data Info = Info {
    frames :: Count,    -- ^Number of frames in file
    samplerate :: Int,  -- ^Audio sample rate
    channels :: Int,    -- ^Number of channels
    format :: Format,   -- ^Header and sample format
    sections :: Int,    -- ^Number of sections
    seekable :: Bool    -- ^'True' when stream is seekable (e.g. local files)
} deriving (Eq, Show)

-- |Return soundfile duration in seconds computed via the 'Info' fields 'frames' and 'samplerate'.
duration :: Info -> Double
duration info = (fromIntegral $ frames info) / (fromIntegral $ samplerate info)

-- |Default \'empty\' info, useful when opening files for reading with 'ReadMode'.
defaultInfo :: Info
defaultInfo   = Info 0 0 0 defaultFormat 0 False

-- |This function allows the caller to check if a set of parameters in the 'Info' struct is valid before calling 'openFile' ('WriteMode').
--
-- 'checkFormat' returns 'True' if the parameters are valid and 'False' otherwise.

{-# NOINLINE checkFormat #-}
checkFormat :: Info -> Bool
checkFormat info =
    unsafePerformIO (with info (liftM cToBool . {#call unsafe sf_format_check#} . castPtr))

-- Storable instance for Info
instance Storable (Info) where
    alignment _ = alignment (undefined :: CInt) -- hmm
    sizeOf _ = {#sizeof INFO#}
    -- Unmarshall Info from C representation
    peek ptr = do
        frames     <- liftM fromIntegral $ {#get SF_INFO.frames#} ptr
        samplerate <- liftM fromIntegral $ {#get SF_INFO.samplerate#} ptr
        channels   <- liftM fromIntegral $ {#get SF_INFO.channels#} ptr
        format     <- liftM hsFormat     $ {#get SF_INFO.format#} ptr
        sections   <- liftM fromIntegral $ {#get SF_INFO.sections#} ptr
        seekable   <- liftM toBool       $ {#get SF_INFO.seekable#} ptr
        return $ Info {
            frames = frames,
            samplerate = samplerate,
            channels = channels,
            format = format,
            sections = sections,
            seekable = seekable
        }
    -- Marshall Info to C representation
    poke ptr info =
        do
            {#set SF_INFO.frames#} ptr     $ fromIntegral $ frames info
            {#set SF_INFO.samplerate#} ptr $ fromIntegral $ samplerate info
            {#set SF_INFO.channels#} ptr   $ fromIntegral $ channels info
            {#set SF_INFO.format#} ptr     $ cFormat      $ format info
            {#set SF_INFO.sections#} ptr   $ fromIntegral $ sections info
            {#set SF_INFO.seekable#} ptr   $ fromBool     $ seekable info

-- ====================================================================
-- Exceptions

checkHandle :: HandlePtr -> IO ()
checkHandle handle = do
    code <- liftM fromIntegral $ {#call unsafe sf_error#} handle
    when (code /= 0) $
        peekCString ({#call pure sf_strerror#} handle) >>= E.throw code

-- ====================================================================
-- Handle operations

-- | Abstract file handle.
data Handle = Handle {
    hInfo :: Info,      -- ^Return the stream 'Info' associated with the 'Handle'.
    hPtr :: HandlePtr
}
type HandlePtr = Ptr ()

-- | I\/O mode.
{#enum IOMode {} deriving (Eq, Show)#}
#c
enum IOMode
{
    ReadMode        = SFM_READ,
    WriteMode       = SFM_WRITE,
    ReadWriteMode   = SFM_RDWR
};
#endc

-- |When opening a file for read ('ReadMode'), the format field should be set to 'defaultFormat' before calling 'openFile'. The only exception to this is the case of RAW files, where the caller has to set the samplerate, channels and format fields to valid values. All other fields of the structure are filled in by the library.
--
-- When opening a file for write ('WriteMode'), the caller must fill in the structure members samplerate, channels, and format.
--
-- Every call to 'openFile' should be matched with a call to 'hClose' to free up memory allocated during the call to 'openFile'.
--
-- On success, the 'openFile' function returns a 'Handle' which should be passed as the first parameter to all subsequent libsndfile calls dealing with that audio stream. On fail, the 'openFile' function signals an 'Exception'.
openFile :: FilePath -> IOMode -> Info -> IO Handle
openFile filePath ioMode info =
    withCString filePath (\cFilePath ->
        with info (\cInfo -> do
            cHandle <- {#call unsafe sf_open#}
                            cFilePath (cFromEnum ioMode) (castPtr cInfo)
            checkHandle cHandle
            newInfo <- peek cInfo
            return $ Handle newInfo cHandle))

-- | The 'hClose' function closes the stream, deallocates its internal buffers and returns () on success or signals an 'Exception' otherwise.
hClose :: Handle -> IO ()
hClose handle = do
    _ <- {#call unsafe sf_close#} $ hPtr handle
    checkHandle nullPtr
    return ()

-- | If the stream is opened with 'WriteMode' or 'ReadWriteMode', call the operating system\'s function to force the writing of all file cache buffers to disk. If the file is opened with 'ReadMode' no action is taken.
hFlush :: Handle -> IO ()
hFlush (Handle _ handle) = {#call unsafe sf_write_sync#} handle

-- |Get header format information associated with file.
getFileInfo :: FilePath -> IO Info
getFileInfo filePath = do
    h <- openFile filePath ReadMode defaultInfo
    let info = hInfo h
    hClose h
    return info

-- ====================================================================
-- seeking

hIsSeekable :: Handle -> IO Bool
hIsSeekable = return . seekable . hInfo

{#enum SeekMode {} deriving (Eq, Show)#}
#c
enum SeekMode
{
    AbsoluteSeek    = SEEK_SET,
    RelativeSeek    = SEEK_CUR,
    SeekFromEnd     = SEEK_END
};
#endc

-- Helper function for seeking, modifying either the read pointer, the write pointer, or both.
{-# INLINE hSeek' #-}
hSeek' :: Maybe IOMode -> Handle -> SeekMode -> Count -> IO Count
hSeek' ioMode (Handle _ handle) seekMode frames = do
    n <- liftM fromIntegral $
            {#call unsafe sf_seek#}
                handle
                (cIntConv frames)
                ((cFromEnum seekMode) .|. (case ioMode of
                                                Nothing -> 0
                                                Just m -> cFromEnum m))
    checkHandle handle
    return n

-- |The file seek functions work much like 'System.IO.hseek' with the exception that the non-audio data is ignored and the seek only moves within the audio data section of the file. In addition, seeks are defined in number of (multichannel) frames. Therefore, a seek in a stereo file from the current position forward with an offset of 1 would skip forward by one sample of both channels.
--
-- like lseek(), the whence parameter can be any one of the following three values:
--
-- * 'AbsoluteSeek' - The offset is set to the start of the audio data plus offset (multichannel) frames.
--
-- * 'RelativeSeek' - The offset is set to its current location plus offset (multichannel) frames.
--
-- * 'SeekFromEnd' - The offset is set to the end of the data plus offset (multichannel) frames.
--
-- Internally, libsndfile keeps track of the read and write locations using separate read and write pointers. If a file has been opened with a mode of 'ReadWriteMode', calling either 'hSeekRead' or 'hSeekWrite' allows the read and write pointers to be modified separately. 'hSeek' modifies both the read and the write pointer.
--         
-- Note that the frames offset can be negative and in fact should be when SeekFromEnd is used for the whence parameter.
--         
-- 'hSeek' will return the offset in (multichannel) frames from the start of the audio data, or signal an error when an attempt is made to seek beyond the start or end of the file.

hSeek :: Handle -> SeekMode -> Count -> IO Count
hSeek = hSeek' Nothing

--hSeek (Handle _ handle) seekMode frames = do
--    n <- liftM fromIntegral $ {#call unsafe sf_seek#} handle (cIntConv frames) (cFromEnum seekMode)
--    checkHandle handle
--    return n

-- |Like 'hSeek', but only the read pointer is modified.
hSeekRead :: Handle -> SeekMode -> Count -> IO Count
hSeekRead = hSeek' (Just ReadMode)

-- |Like 'hSeek', but only the write pointer is modified.
hSeekWrite :: Handle -> SeekMode -> Count -> IO Count
hSeekWrite = hSeek' (Just WriteMode)

-- ====================================================================
-- string access

-- |Header string field types.
{#enum StringType {underscoreToCase} deriving (Eq, Show)#}
#c
enum StringType
{
    STR_TITLE       = SF_STR_TITLE,
    STR_COPYRIGHT   = SF_STR_COPYRIGHT,
    STR_SOFTWARE    = SF_STR_SOFTWARE,
    STR_ARTIST      = SF_STR_ARTIST,
    STR_COMMENT     = SF_STR_COMMENT,
    STR_DATE        = SF_STR_DATE
};
#endc

-- |The 'getString' function returns the specificed string from the stream header in the 'Maybe' monad if it exists and 'Nothing' otherwise.
getString :: Handle -> StringType -> IO (Maybe String)
getString (Handle _ handle) t = do
    ptr <- {#call unsafe sf_get_string#} handle (cFromEnum t)
    if ptr == (nullPtr :: Ptr CChar)
        then return Nothing
        else liftM Just $ peekCString =<< (return ptr)


-- |The 'setString' function sets the string data associated with the respective 'StringType'.
setString :: Handle -> StringType -> String -> IO ()
setString (Handle _ handle) t s =
    withCString s (\cs -> do
        _ <- {#call unsafe sf_set_string#} handle (cFromEnum t) cs
        checkHandle handle
        return ())