Csound.hs

-- |Sound.Csound provides a Haskell interface to the Csound API (defined in csound.h).
-- (almost) all functions from the API are wrapped and marshalled in Sound.CSound.Interface.
-- In addition to the raw functions provided there, Sound.CSound provides many more convenient
-- to use when calling csound, as well as marshalling for some functions that return vectors.
--
-- C++ class files, such as CSoundFile.hpp, are not yet wrapped.  Also support for cscore is
-- currently very limited.

module Sound.Csound
	(
                CsoundMonad, --exported from Interface
                csoundCreate,
                csoundCompile,
                csoundPerform,
                CsoundPerformStatus,
                csoundPreCompile,
                csoundSetHostImplementedAudioIO,

-- defined in this module
                csoundPerformKsmpsIO,
                csoundPerformBufferIO,
                withOpcodeList,
                withUtilityList,
                listUtilityNames,
                withChannelList
	)
where

import Sound.Csound.Interface
import Foreign.Marshal.Array (peekArray, pokeArray)
import Control.Monad.Error (liftIO, throwError)
import Control.Exception (bracket)

-- Functions to perform a score with input and output from the host.

-- |Perform an entire score using csoundPerformKsmps, with handling of
-- input and output buffers spin and spout.  Note that
-- csoundSetHostImplementedIO must be called before csoundCompile.
csoundPerformKsmpsIO ::
        CsoundPtr -- ^Pointer to csound instance
        -> (Int -> Int -> IO [CsndFlt]) -- ^Function that takes buffer size and starting
                                        -- position (in samples) and returns a list of length
                                        -- buffersize of input to use.
        -> (Int -> Int -> [CsndFlt] -> IO ()) -- ^Function that takes buffer size, starting
                                              -- position (in samples), and list of CsndFlt
                                              -- and performs an IO action with the [CsndFlt]
        -> CsoundMonad ()
csoundPerformKsmpsIO csPtr inBuf outBuf = csoundPerformKsmpsIO' 0
        where
        bufSize = csoundGetKsmps csPtr
        ifn = inBuf bufSize
        ofn = outBuf bufSize
        peekFn = peekArray bufSize
        csoundPerformKsmpsIO' :: Int -> CsoundMonad ()
        csoundPerformKsmpsIO' iposAcc = do
                liftIO $ csoundGetSpin' csPtr >>= (\iptr -> ifn iposAcc >>= pokeArray iptr)
                res <- csoundPerformKsmps csPtr
                liftIO $ csoundGetSpout' csPtr >>= peekFn >>= (ofn iposAcc)
                case res of
                        PerformStopped -> let newPosAcc = iposAcc + bufSize in
                                csoundPerformKsmpsIO' newPosAcc
                        PerformFinished -> return ()
                        _ -> throwError $ show res --I don't think this will ever happen,
                            -- because if it does csoundPerformKsmps should handle the error

-- |Perform an entire score using csoundPerformBuffer, with handling of
-- input and output buffers.
csoundPerformBufferIO ::
        CsoundPtr -- ^Pointer to Csound struct
        -> (Int -> Int -> IO [CsndFlt]) -- ^Function that takes buffer size and starting
                                -- position (in samples) and returns a list of length
                                -- buffersize of input to use.
        -> (Int -> Int -> [CsndFlt] -> IO ()) -- ^Function that takes buffer size, starting
                                              -- position (in samples), and list of CsndFlt
                                              -- and performs an IO action with the [CsndFlt]
        -> CsoundMonad ()
csoundPerformBufferIO csp inBuf outBuf = csoundPerformBufferIO' 0
        where
        inBufSize = csoundGetInputBufferSize csp
        ifn = inBuf inBufSize
        outBufSize = csoundGetOutputBufferSize csp
        ofn = outBuf outBufSize
        peekFn = peekArray $ csoundGetInputBufferSize csp
        csoundPerformBufferIO' :: Int -> CsoundMonad ()
        csoundPerformBufferIO' iposAcc = do
                liftIO $ csoundGetInputBuffer' csp >>= (\iptr -> ifn iposAcc >>= pokeArray iptr)
                res <- csoundPerformBuffer csp
                liftIO $ csoundGetOutputBuffer' csp >>= peekFn >>= (ofn iposAcc)
                case res of
                        PerformStopped -> let newPosAcc = iposAcc+inBufSize in
                                csoundPerformBufferIO' newPosAcc
                        PerformFinished -> return ()
                        _ -> throwError $ show res --Again, this should never happen

-- |Perform an IO action with the current csound opcode list, properly disposing of the list after completing
-- the action
withOpcodeList :: CsoundPtr -> ([OpcodeListEntry] -> IO b) -> CsoundMonad b
withOpcodeList csPtr func = do
        openRes <- csoundNewOpcodeList csPtr
        liftIO $ bracket (return openRes) disposeFunc procFunc
        where
        disposeFunc = (\(ptr, _) -> csoundDisposeOpcodeList csPtr ptr)
        procFunc = (\(_, list) -> func list)

-- |Perform an action within the IO monad, using the list of named utilities.
withUtilityList :: CsoundPtr -> ([String] -> IO b) -> CsoundMonad b
withUtilityList csPtr func = do
        openRes <- csoundListUtilities csPtr
        case openRes of
                (_, []) -> throwError "No utilities found."
                _ -> liftIO $ bracket (return openRes) disposeFunc procFunc
        where
        disposeFunc = (\(ptr, _) -> csoundDeleteUtilityList csPtr ptr)
        procFunc = (\(_, list) -> func list)

-- |Get a list of all the registered csound utilities.  This should be used instead of csoundListUtilities
-- because this function calls csoundDeleteUtilityList after use.
listUtilityNames :: CsoundPtr -> CsoundMonad [String]
listUtilityNames csPtr = withUtilityList csPtr return

-- |Perform an action within the IO monad, using the list of channels.
withChannelList :: CsoundPtr -> ([CsoundChannelListEntry] -> IO a) -> CsoundMonad a
withChannelList csPtr func = do
        openRes <- csoundListChannels csPtr
        case openRes of
                (_, []) -> throwError "No open channels"
                _ -> liftIO $ bracket (return openRes) disposeFunc procFunc
        where
        disposeFunc = (\(ptr, _) -> csoundDeleteChannelList csPtr ptr)
        procFunc = (\(_, list) -> func list)

-- |Perform a simple run of csound, with no special handling.
{-
runCsoundSimple :: String -> CsoundMonad CsoundPerformStatus
runCsoundSimple argList = do
        perfStatus <- liftIO $ bracket (csoundCreate nullPtr) csoundDestroy perform
	where
        perform csPtr = do
                res <- csoundCompile csPtr argv argc
                case res of
                        CsoundSuccess -> csoundPerform csPtr
                        otherwise -> return $ PerformError res
        argc = "csound" : words argList
	argv = length argc
-}