{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving #-}

-- |Interface to csound.h
-- This module contains all foreign import statements, Haskell
-- representations of most csound datatypes
-- and their Storable instances, and some extra marshalling functions.

module Sound.Csound.Interface where

import Prelude
import C2HS
import Control.Monad (liftM)
import Control.Monad.Error (ErrorT, liftIO, throwError)
import Data.Bits
import Data.List ( foldl')
import qualified Control.Monad.Cont as Cont

#include <csound.h>

-- **Haskell representations of basic csound types.
-- |Type for one audio sample value.  CsndFlt is a double regardless of the size of CSNDFLT
type CsndFlt = Double

#ifndef USE_DOUBLE
-- |C representation of CSNDFLT, depending on if USE_DOUBLE is defined.
type CCsndFlt = CFloat
#else
type CCsndFlt = CDouble
#endif

type IntLeast64T = {#type int_least64_t#}
type UInt32T = {#type uint32_t#}
type UIntPtrT = {#type uintptr_t#}

-- **The CsoundMonad and associated functions
type CsoundMonad = ErrorT String IO -- ^Wrap IO and produce error messages as applicable.

-- |Wrap functions that return CsoundStatus into the CsoundMonad
-- for error handling
csoundStatusWrapper :: IO CsoundStatus -> CsoundMonad ()
csoundStatusWrapper csoundFunc = do
        res <- liftIO csoundFunc
        case res of
                CsoundSuccess -> return ()
                _ -> throwError $ show res

-- |Wrap functions that return a CsoundStatus and one other value into the
-- CsoundMonad for error handling.
csoundStatValWrapper :: IO (CsoundStatus, a) -> CsoundMonad a
csoundStatValWrapper func = do
        (stat, output) <- liftIO func
        case stat of
                CsoundSuccess -> return output
                _ -> throwError $ show stat

-- |Wrap functions that return CsoundPerformStatus into the CsoundMonad.
csPerformStatusWrapper :: IO CsoundPerformStatus ->
                          CsoundMonad CsoundPerformStatus
csPerformStatusWrapper csoundFunc = do
        res <- liftIO csoundFunc
        case res of
                PerformError _ -> throwError $ show res
                _ -> return res

-- |Wrap any function from IO monad to CsoundMonad
csoundWrapper :: (a -> IO b) -> a -> CsoundMonad b
csoundWrapper fn v = liftIO $ fn v
{-# INLINE csoundWrapper #-}

-- |Wrap functions that return Bool into the CsoundMonad
boolWrapper :: String -> IO Bool -> CsoundMonad ()
boolWrapper errStr action = do
        res <- liftIO action
        case res of
                True -> return ()
                False -> throwError errStr

{#pointer *CSOUND as CsoundPtr newtype#}
{#pointer *FILE as FilePtr newtype#}
{#pointer *PVSDATEXT as PvsDatExtPtr -> PvsDatExt#}

-- **Enumerations.
-- | Flags for csoundInitialize().
data CsoundInit =
        CsoundInitNoSignalHandler
        | CsoundInitNoAtExit
-- rather than hardwiring the enums, I should probably use cpp on this file
-- to get the values directly from the header.
instance Enum CsoundInit where
  fromEnum CsoundInitNoSignalHandler = 1
  fromEnum CsoundInitNoAtExit = 2

  toEnum 1 = CsoundInitNoSignalHandler
  toEnum 2 = CsoundInitNoAtExit
  toEnum unmatched = error ("CsoundInit.toEnum: Cannot match " ++ show unmatched)

-- |Csound Languages.
{#enum cslanguage_t as CsLanguage {underscoreToCase} deriving (Eq, Show)#}

-- |CSound status.
{#enum CSOUND_STATUS as CsoundStatus {underscoreToCase} deriving (Eq, Show)#}

-- |CsoundPerform results
data CsoundPerformStatus =
        PerformFinished
        | PerformStopped
        | PerformError CsoundStatus deriving Show

-- |The return values of the csoundSetCallback function.
data CsoundSetCallbackStatus =
        SetCallbackOk
        | SetCallbackError CsoundStatus
        | SetCallbackIgnored Int
        deriving (Eq, Show)

-- |Csound callback function types.
-- A callback function will receive one of these types to specify the type
-- of event calling it.
-- when setting a callback, the bitwise 'or' of all desired types should
-- be used (or the special 'alltypes' value).

data CsoundCallbackFunctionType =
        CsoundCallbackAllTypes
        | CsoundCallbackKbdEvent
        | CsoundCallbackKbdText
        deriving (Eq)
instance Enum CsoundCallbackFunctionType where
        fromEnum CsoundCallbackAllTypes = 0
        fromEnum CsoundCallbackKbdEvent = 1
        fromEnum CsoundCallbackKbdText = 2

        toEnum 0 = CsoundCallbackAllTypes
        toEnum 1 = CsoundCallbackKbdEvent
        toEnum 2 = CsoundCallbackKbdText
        toEnum unmatched = error
          ("CsoundCallbackFunctionType.toEnum: Cannot match " ++ show unmatched)

newtype CsoundCallbackFunctionTypeMask = CsoundCallbackFunctionTypeMask Int
        deriving (Eq, Num, Ord, Show, Real, Enum, Integral, Bits)

typeToMask :: CsoundCallbackFunctionType -> CsoundCallbackFunctionTypeMask
typeToMask CsoundCallbackAllTypes = 0
typeToMask typ = fromIntegral $ fromEnum typ

-- |Create a TypeMask from a list of CsoundCallbackFunctionType
createTypeMask :: [CsoundCallbackFunctionType] -> CsoundCallbackFunctionTypeMask
createTypeMask = foldl' orFunc (-1)
        where
        orFunc (-1) r = typeToMask r --ignore a (-1) type
        orFunc _ CsoundCallbackAllTypes = 0
        orFunc 0 _ = 0
        orFunc l r = l .|. typeToMask r

-- | Filetypes recognized by CSound
{#enum CSOUND_FILETYPES as CsoundFiletypes {underscoreToCase} deriving (Eq, Show)#}

-- **Utility marshalling functions

-- |Marshal an enumeration to a CInt
cIntFromEnum :: Enum a => a -> CInt
cIntFromEnum = cIntConv . fromEnum

-- |Marshal a CInt to an enumeration
cIntToEnum :: Enum a => CInt -> a
cIntToEnum = toEnum . cIntConv

-- |Marshal a CInt to Bool.  False if CInt== 0, otherwise true.
cIntToBool :: CInt -> Bool
cIntToBool val | val == 0 = False
        | otherwise = True

-- |Marshal a CInt to Bool.  True if CInt== 0, otherwise false.
-- Some standardization of the underlying library would be nice.
-- Even better is knowing that it will never be fixed.
cIntToBoolSwitch :: CInt -> Bool
cIntToBoolSwitch val | val == 0 = True
        | otherwise = False

-- |Marshal a CInt to a Maybe Int, Nothing if CInt <0
maybeCInt :: CInt -> Maybe Int
maybeCInt i
        | i >= 0 = Just $ cIntConv i
        | otherwise = Nothing

-- |Check if a Ptr () is valid or not.
checkNullPtr :: Ptr () -> Maybe (Ptr ())
checkNullPtr ptr
        | ptr == nullPtr = Nothing
        | otherwise = Just ptr

-- |Create a CsoundPerformStatus
toCsoundPerformStatus :: CInt -> CsoundPerformStatus
toCsoundPerformStatus a
        | a == 0 = PerformStopped
        | a < 0  = PerformError $ cIntToEnum a
        | otherwise = PerformFinished

cIntToSetCallbackStatus :: CInt -> CsoundSetCallbackStatus
cIntToSetCallbackStatus 0 = SetCallbackOk
cIntToSetCallbackStatus val = case (val < 0) of
        True -> SetCallbackError $ cIntToEnum val
        False -> SetCallbackIgnored $ cIntConv val

-- |Marshal a list of CsndFlt to an array of MYFLT.
withCsndFltArray :: (Storable b, RealFloat b, RealFloat a) => [a]
                    -> (Ptr b -> IO b1)
                    -> IO b1
withCsndFltArray = withArray . map (cFloatConv)

nest :: [(r -> a) -> a] -> ([r] -> a) -> a
nest xs = Cont.runCont (sequence (map Cont.Cont xs))

-- |Marshal a [String] to a (Ptr (Ptr CChar))
withStringList :: [String] -> (Ptr CString -> IO a) -> IO a
withStringList strings act = nest (map withCString strings)
                                    (\rs -> withArray0 nullPtr rs act)

-- |Marshal (Ptr (Ptr CChar)) to [String].
-- Keep track of the original pointer because it will often
-- need to be manually freed.
peekStringArrayPtr :: Ptr (Ptr (CChar)) -> IO (Ptr (CString), [String])
peekStringArrayPtr ptrPtr = do
        strAry <- peekStringArray ptrPtr
        return (ptrPtr, strAry)

peekStringArray :: Ptr CString -> IO [String]
peekStringArray ptrPtr = withCString "" (\nul-> do
        cstrAry <- peekArray0 nul ptrPtr
        mapM peekCAString cstrAry
        )

-- |since c2hs doesn't allow "with" as an input marshaller,
-- withObject is a synonym.
withObject :: Storable a => a -> (Ptr a -> IO b) -> IO b
withObject = with

-- |Peek from a Ptr CFloat to a CsndFloat
peekCsndFlt :: Ptr CCsndFlt -> IO CsndFlt
peekCsndFlt a = peek a >>= \x -> return $ cFloatConv x

-- |Marshal a Ptr (Ptr CFloat) to a Ptr (CsndFlt).
-- This is very likely broken.
peekCsndOutAry :: Ptr (Ptr CCsndFlt) -> IO (Ptr CsndFlt)
peekCsndOutAry ptrPtr = peek ptrPtr >>= \ptr -> return $ castPtr ptr

-- |Variation on PVSDAT used in the pvs bus interface.
-- The two parameters sliding and nb are only present
-- #ifdef SDFT.  If compiled with SDFT support, the fields will be Just a,
-- otherwise they will be Nothing.
-- hCsound does not currently implement SDFT.
data PvsDatExt = PvsDatExt {
        n :: Int,
        sliding :: Maybe Int,
        nb :: Maybe Int,
        overlap :: Int,
        winsize :: Int,
        wintype :: Int,
        format :: Int,
        framecount :: Int,
        frame :: Ptr CFloat
        }
instance Storable (PvsDatExt) where
        alignment _ = alignment (undefined :: CInt)
        sizeOf _ = {#sizeof PVSDATEXT#}
        peek p = do
                nV <- liftM fromIntegral $ {#get PVSDATEXT.N#} p
#ifdef SDFT
                slidingV <- liftM Just . fromIntegral $
                            {#get PVSDATEXT.sliding#} p
                nbV <- liftM Just . fromIntegral $ {#get PVSDATEXT.NB#} p
#else
                let slidingV = Nothing
                let nbV = Nothing
#endif
                overlapV <- liftM fromIntegral $ {#get PVSDATEXT.overlap#} p
                winsizeV <- liftM fromIntegral $ {#get PVSDATEXT.winsize#} p
                wintypeV <- liftM fromIntegral $ {#get PVSDATEXT.wintype#} p
                formatV <- liftM fromIntegral $ {#get PVSDATEXT.format#} p
                framecountV <- liftM fromIntegral $
                               {#get PVSDATEXT.framecount#} p
                frameV <- {#get PVSDATEXT.frame#} p
                return $ PvsDatExt nV slidingV nbV overlapV winsizeV
                          wintypeV formatV framecountV frameV
        poke p pvs = do
                {#set PVSDATEXT.N#} p $ fromIntegral $ n pvs
#ifdef SDFT
                -- If the structure was marshalled from C, these will have a
                -- value. If these are Nothing and SDFT is defined,
                -- it should be an error anyway.
                {#set PVSDATEXT.sliding#} p $ fromIntegral . fromJust $
                  sliding pvs
                {#set PVSDATEXT.NB#} p $ fromIntegral . fromJust $ nb pvs
#endif
                {#set PVSDATEXT.overlap#} p $ fromIntegral $ overlap pvs
                {#set PVSDATEXT.winsize#} p $ fromIntegral $ winsize pvs
                {#set PVSDATEXT.wintype#} p $ fromIntegral $ wintype pvs
                {#set PVSDATEXT.format#} p $ fromIntegral $ format pvs
                {#set PVSDATEXT.framecount#} p $ fromIntegral $ framecount pvs
                {#set PVSDATEXT.frame#} p $ frame pvs

-- *Csound Initialization functions
{- I don't want to do this yet; I don't know if the input values are
retained by the csound library.
{#fun unsafe csoundInitialize as ^
        {
                `Int',
                strAryInMarshal* `[String]',
                `Int'
        } -> `Int'#}
-}

csoundCreate :: CsoundMonad CsoundPtr
csoundCreate = liftIO $ unsafeCsoundCreate nullPtr

unsafeCsoundCreate :: Ptr () -> IO (CsoundPtr)
unsafeCsoundCreate = {#call unsafe csoundCreate as uCsoundCreate_#}

csoundPreCompile :: CsoundPtr -> CsoundMonad ()
csoundPreCompile csPtr = csoundStatusWrapper $ unsafeCsoundPreCompile csPtr

{#fun unsafe csoundPreCompile as unsafeCsoundPreCompile
        {id `CsoundPtr'} -> `CsoundStatus' cIntToEnum #}

csoundInitializeCscore :: CsoundPtr -> FilePtr -> FilePtr -> CsoundMonad ()
csoundInitializeCscore csPtr iScore oScore =
        csoundStatusWrapper $ unsafeCsoundInitializeCscore csPtr iScore oScore

{#fun unsafe csoundInitializeCscore as unsafeCsoundInitializeCscore
        {
                id `CsoundPtr',
                id `FilePtr',
                id `FilePtr'
        } -> `CsoundStatus' cIntToEnum#}

csoundQueryInterface :: String -> CsoundMonad (CsoundStatus, Ptr (), Int)
csoundQueryInterface str = do
        res <- liftIO $ csoundQueryInterface' str
        case res of
                (CsoundSuccess, _, _) -> return res
                (errCode, _, _) -> throwError $ show errCode

-- |Returns (Result, ptr to interface, version number) if the interface is available.
{#fun csoundQueryInterface as csoundQueryInterface'
        {
                `String',
                alloca- `Ptr ()' peek*,
                alloca- `Int' peekIntConv*
        } -> `CsoundStatus' cIntToEnum#}

csoundDestroy :: CsoundPtr -> CsoundMonad ()
csoundDestroy =  csoundWrapper {#call unsafe csoundDestroy as uCsoundDestroy_#}

{#fun pure unsafe csoundGetVersion {} -> `Int'#}

{#fun pure unsafe csoundGetAPIVersion as csoundGetApiVersion {} -> `Int'#}

csoundGetHostData :: CsoundPtr -> CsoundMonad (Ptr ())
csoundGetHostData = csoundWrapper
                     {#call csoundGetHostData as csoundGetHostData_#}

csoundSetHostData :: CsoundPtr -> Ptr () -> CsoundMonad ()
csoundSetHostData csp p = liftIO $
    {#call csoundSetHostData as csoundSetHostData_#} csp p

{#fun csoundGetEnv {id `CsoundPtr', `String'} ->  `String'#}

csoundSetGlobalEnv :: String -> String -> CsoundMonad ()
csoundSetGlobalEnv name value = csoundStatusWrapper $
                                csoundSetGlobalEnv' name value

{#fun csoundSetGlobalEnv as csoundSetGlobalEnv' {`String', `String'} -> `CsoundStatus' cIntToEnum#}

-- *Performance functions
csoundCompile :: CsoundPtr -> String -> CsoundMonad ()
csoundCompile csPtr argList = csoundStatusWrapper $
                              csoundCompile' csPtr argv argc
        where
        argc = "csound" : words argList
	argv = length argc

{#fun unsafe csoundCompile as csoundCompile' {
        id `CsoundPtr',
        `Int',
        withStringList* `[String]'
        } -> `CsoundStatus' cIntToEnum#}

csoundPerform :: CsoundPtr -> CsoundMonad CsoundPerformStatus
csoundPerform csPtr = csPerformStatusWrapper $ csoundPerform' csPtr

{#fun csoundPerform as csoundPerform' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#}

csoundPerformKsmps :: CsoundPtr -> CsoundMonad CsoundPerformStatus
csoundPerformKsmps csPtr = csPerformStatusWrapper $ csoundPerformKsmps' csPtr

{#fun csoundPerformKsmps as csoundPerformKsmps' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#}

csoundPerformKsmpsAbsolute :: CsoundPtr -> CsoundMonad CsoundPerformStatus
csoundPerformKsmpsAbsolute csPtr = csPerformStatusWrapper $
                                   csoundPerformKsmpsAbsolute' csPtr

{#fun csoundPerformKsmpsAbsolute as csoundPerformKsmpsAbsolute'
        {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#}

csoundPerformBuffer :: CsoundPtr -> CsoundMonad CsoundPerformStatus
csoundPerformBuffer csPtr = csPerformStatusWrapper $ csoundPerformBuffer' csPtr

{#fun csoundPerformBuffer as csoundPerformBuffer' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#}

{#fun csoundStop {id `CsoundPtr'} -> `()'#}

{#fun csoundCleanup {id `CsoundPtr'} -> `Int'#}

{#fun csoundReset {id `CsoundPtr'} -> `()'#}

-- *Csound Attributes
{#fun pure unsafe csoundGetSr { id `CsoundPtr'} -> `CsndFlt' cFloatConv#}

{#fun pure unsafe csoundGetKr { id `CsoundPtr'} -> `CsndFlt' cFloatConv#}

{#fun pure unsafe csoundGetKsmps { id `CsoundPtr'} -> `Int'#}

{#fun pure unsafe csoundGetNchnls { id `CsoundPtr'} -> `Int'#}

{#fun pure unsafe csoundGet0dBFS { id `CsoundPtr'} -> `CsndFlt' cFloatConv#}

{#fun pure unsafe csoundGetStrVarMaxLen { id `CsoundPtr'} -> `Int'#}

{#fun pure unsafe csoundGetSampleFormat { id `CsoundPtr'} -> `Int'#}

{#fun pure unsafe csoundGetSampleSize { id `CsoundPtr'} -> `Int'#}

{#fun pure unsafe csoundGetInputBufferSize { id `CsoundPtr'} -> `Int'#}

{#fun pure unsafe csoundGetOutputBufferSize { id `CsoundPtr'} -> `Int'#}

-- *Input\/output functions
-- **These functions return a MYFLT array.  To marshall this to haskell,
-- you need to first get the size of the array (using getInputBufferSize,
-- getOutputBufferSize, or getKsmps),
-- then the output can be marshalled with
-- Foreign.Marshal.Array.peekArray
-- There are some convience functions in Sound.Csound that do some of this.
{#fun unsafe csoundGetInputBuffer as csoundGetInputBuffer' { id `CsoundPtr'}
        -> `Ptr CsndFlt' castPtr#}

{#fun unsafe csoundGetOutputBuffer as csoundGetOutputBuffer' { id `CsoundPtr'}
        -> `Ptr CsndFlt' castPtr#}

{#fun unsafe csoundGetSpin as csoundGetSpin' { id `CsoundPtr'}
        -> `Ptr CsndFlt' castPtr#}

{#fun unsafe csoundGetSpout as csoundGetSpout' { id `CsoundPtr'}
        -> `Ptr CsndFlt' castPtr#}

{#fun unsafe csoundGetOutputFileName { id `CsoundPtr'}
        -> `String'#}

-- |Call between csoundPreCompile and csoundCompile to set Host Implemented IO
{#fun unsafe csoundSetHostImplementedAudioIO {
        id `CsoundPtr',
        `Int',
        `Int'
        } -> `()'#}

-- *Score handling functions.
{#fun unsafe csoundGetScoreTime { id `CsoundPtr'}
        -> `CsndFlt' cFloatConv#}

{#fun unsafe csoundIsScorePending { id `CsoundPtr'} -> `Int'#}

{#fun unsafe csoundSetScorePending
        {
        id `CsoundPtr',
        `Int'}
        -> `()'#}

{#fun unsafe csoundGetScoreOffsetSeconds { id `CsoundPtr'}
        -> `CsndFlt' cFloatConv#}

{#fun unsafe csoundSetScoreOffsetSeconds
        {
        id `CsoundPtr',
        cFloatConv `CsndFlt' }
        -> `()'#}

csoundRewindScore :: CsoundPtr -> IO ()
csoundRewindScore =
        {#call csoundRewindScore as csoundRewindScore_#}

csoundSetCscoreCallback :: CsoundPtr -> FunPtr (CsoundPtr -> IO ()) -> IO ()
csoundSetCscoreCallback =
        {#call csoundSetCscoreCallback as csoundSetCscoreCallback_#}

csoundScoreSort :: CsoundPtr -> FilePtr -> FilePtr -> CsoundMonad ()
csoundScoreSort csPtr inFile outFile = csoundStatusWrapper $ csoundScoreSort' csPtr inFile outFile

{#fun csoundScoreSort as csoundScoreSort'
        {
                id `CsoundPtr',
                id `FilePtr',
                id `FilePtr'
        } -> `CsoundStatus' cIntToEnum#}

csoundScoreExtract :: CsoundPtr -> FilePtr -> FilePtr -> FilePtr -> CsoundMonad ()
csoundScoreExtract csPtr inFile outFile extractFile =
        csoundStatusWrapper $ csoundScoreExtract' csPtr inFile outFile extractFile

{#fun csoundScoreExtract as csoundScoreExtract'
        {
                id `CsoundPtr',
                id `FilePtr',
                id `FilePtr',
                id `FilePtr'
        } -> `CsoundStatus' cIntToEnum#}

-- *Messages and Text
{#fun pure unsafe csoundGetMessageLevel {id `CsoundPtr'} -> `Int'#}

{#fun unsafe csoundSetMessageLevel
        {
                id `CsoundPtr',
                `Int'
        } -> `()'#}

{#fun unsafe csoundInputMessage
        {
                id `CsoundPtr',
                `String'
        } -> `()'#}

{#fun csoundKeyPress
        {
                id `CsoundPtr',
                castCharToCChar `Char'
        } -> `()'#}

-- *Control and events
-- these functions are used by the \'invalue\' and \'outvalue\' opcodes.
-- **Callback types
-- |Csound Instance, Channel name, Value read (in csound) from channel
type InputValueCallback  = FunPtr (
        CsoundPtr
        -> CString
        -> Ptr CCsndFlt
        -> IO () )
-- |Csound instance, channel name, value to write (from csound) to channel
type OutputValueCallback = FunPtr (
        CsoundPtr
        -> CString
        -> CCsndFlt
        -> IO ())

-- **Set csound callbacks
-- |called by 'invalue' opcode.
csoundSetInputValueCallback ::
        CsoundPtr
        -> InputValueCallback
        -> IO ()
csoundSetInputValueCallback =
        {#call csoundSetInputValueCallback as csoundSetInputValueCallback_#}

-- |called by 'outvalue' opcode.
csoundSetOutputValueCallback ::
        CsoundPtr
        -> OutputValueCallback
        -> IO ()
csoundSetOutputValueCallback =
        {#call csoundSetOutputValueCallback as csoundSetOutputValueCallback_#}

{#fun csoundScoreEvent
        {
                id `CsoundPtr',
                castCharToCChar `Char',
                withCsndFltArray* `[CsndFlt]',
                `Int'
        } -> `Int'#}

-- *MIDI
-- **MIDI callback function types
-- |Csound instance, **UserData, Device name
type ExternalMidiOpenCallback = FunPtr (
        CsoundPtr
        -> Ptr (Ptr ())
        -> CString
        -> IO CInt)

-- |Csound instance, *UserData, Buffer, number of bytes
type ExternalMidiReadCallback  = FunPtr (
        CsoundPtr
        -> Ptr ()
        -> Ptr CUChar
        -> CInt
        -> IO CInt)

type ExternalMidiWriteCallback = ExternalMidiReadCallback

-- |Csound instance -> *UserData
type ExternalMidiCloseCallback = FunPtr (
        CsoundPtr
        -> Ptr ()
        -> IO CInt)

-- |MIDI error code -> string representation
type ExternalMidiErrorStringCallback = FunPtr (
        CInt
        -> IO CString)

-- **Csound MIDI functions

csoundSetExternalMidiInOpenCallback ::
        CsoundPtr
        -> ExternalMidiOpenCallback
        -> IO ()
csoundSetExternalMidiInOpenCallback =
        {#call csoundSetExternalMidiInOpenCallback as csoundSetExternalMidiInOpenCallback_#}

csoundSetExternalMidiReadCallback ::
        CsoundPtr
        -> ExternalMidiReadCallback
        -> IO ()
csoundSetExternalMidiReadCallback =
        {#call csoundSetExternalMidiReadCallback as csoundSetExternalMidiReadCallback_#}

csoundSetExternalMidiInCloseCallback ::
        CsoundPtr
        -> ExternalMidiCloseCallback
        -> IO ()
csoundSetExternalMidiInCloseCallback =
        {#call csoundSetExternalMidiInCloseCallback as csoundSetExternalMidiInCloseCallback_#}

csoundSetExternalMidiOutOpenCallback ::
        CsoundPtr
        -> ExternalMidiOpenCallback
        -> IO ()
csoundSetExternalMidiOutOpenCallback =
        {#call csoundSetExternalMidiOutOpenCallback as csoundSetExternalMidiOutOpenCallback_#}

csoundSetExternalMidiWriteCallback ::
        CsoundPtr
        -> ExternalMidiWriteCallback
        -> IO ()
csoundSetExternalMidiWriteCallback =
        {#call csoundSetExternalMidiWriteCallback as csoundSetExternalMidiWriteCallback_#}

csoundSetExternalMidiOutCloseCallback ::
        CsoundPtr
        -> ExternalMidiCloseCallback
        -> IO ()
csoundSetExternalMidiOutCloseCallback =
        {#call csoundSetExternalMidiOutCloseCallback as csoundSetExternalMidiOutCloseCallback_#}

csoundSetExternalMidiErrorStringCallback ::
        CsoundPtr
        -> ExternalMidiErrorStringCallback
        -> IO ()
csoundSetExternalMidiErrorStringCallback =
        {#call csoundSetExternalMidiErrorStringCallback as csoundSetExternalMidiErrorStringCallback_#}

-- *Function table display
-- **Callback function types
-- |Ptr to a WINDAT struct.  I haven't made a haskell representation of this.
{#pointer *WINDAT as WinDatPtr#}

type MakeGraphCallback = FunPtr (CsoundPtr -> WinDatPtr -> CString -> IO ())
type DrawGraphCallback = FunPtr (CsoundPtr -> WinDatPtr -> IO ())
type KillGraphCallback = FunPtr (CsoundPtr -> WinDatPtr -> IO ())
type MakeXYinCallback = FunPtr
                        (CsoundPtr ->
                         WinDatPtr ->
                         CCsndFlt ->
                         CCsndFlt ->
                         IO ())
type ReadXYinCallback = FunPtr (CsoundPtr -> WinDatPtr -> IO ())
type KillXYinCallback = FunPtr (CsoundPtr -> WinDatPtr -> IO ())
type ExitGraphCallback = FunPtr (CsoundPtr -> IO CInt)

-- **Csound functions
{#fun csoundSetIsGraphable {id `CsoundPtr', `Int' } -> `Int'#}

csoundSetMakeGraphCallback ::
        CsoundPtr
        -> MakeGraphCallback
        -> IO ()
csoundSetMakeGraphCallback =
        {#call csoundSetMakeGraphCallback as csoundSetMakeGraphCallback_#}

csoundSetDrawGraphCallback ::
        CsoundPtr
        -> DrawGraphCallback
        -> IO ()
csoundSetDrawGraphCallback =
        {#call csoundSetDrawGraphCallback as csoundSetDrawGraphCallback_#}

csoundSetKillGraphCallback ::
        CsoundPtr
        -> KillGraphCallback
        -> IO ()
csoundSetKillGraphCallback =
        {#call csoundSetKillGraphCallback as csoundSetKillGraphCallback_#}

csoundSetMakeXYinCallback ::
        CsoundPtr
        -> MakeXYinCallback
        -> IO ()
csoundSetMakeXYinCallback =
        {#call csoundSetMakeXYinCallback as csoundSetMakeXYinCallback_#}

csoundSetReadXYinCallback ::
        CsoundPtr
        -> ReadXYinCallback
        -> IO ()
csoundSetReadXYinCallback =
        {#call csoundSetReadXYinCallback as csoundSetReadXYinCallback_#}

csoundSetKillXYinCallback ::
        CsoundPtr
        -> KillXYinCallback
        -> IO ()
csoundSetKillXYinCallback =
        {#call csoundSetKillXYinCallback as csoundSetKillXYinCallback_#}

csoundSetExitGraphCallback ::
        CsoundPtr
        -> ExitGraphCallback
        -> IO ()
csoundSetExitGraphCallback =
        {#call csoundSetExitGraphCallback as csoundSetExitGraphCallback_#}

-- *Csound opcodes
-- **Opcode data types
{#pointer *opcodeListEntry as OpcodeListEntryPtr -> OpcodeListEntry#}

data OpcodeListEntry = OpcodeListEntry {
        opcodeName :: CString, -- ^Name of opcode
        ouTypes :: CString, -- ^Output types
        inTypes :: CString -- ^Input types
        }

instance Storable (OpcodeListEntry) where
        alignment _ = 16
        sizeOf _ = {#sizeof opcodeListEntry#}
        peek p = do
                nameV <- {#get opcodeListEntry.opname#} p
                otypesV <- {#get opcodeListEntry.outypes#} p
                itypesV <- {#get opcodeListEntry.intypes#} p
                return $ OpcodeListEntry nameV otypesV itypesV
        poke p li = do
                {#set opcodeListEntry.opname#} p $ opcodeName li
                {#set opcodeListEntry.outypes#} p $ ouTypes li
                {#set opcodeListEntry.intypes#} p $ inTypes li

-- **opcode function types
-- |Type for a callback function of a new csound opcode.
type OpcodeFunction = FunPtr (CsoundPtr -> Ptr () -> IO CInt)

-- **Csound opcode manipulation functions
csoundNewOpcodeList :: CsoundPtr ->
                       CsoundMonad (OpcodeListEntryPtr, [OpcodeListEntry])
csoundNewOpcodeList csptr = do
        (arrayLen, ptr) <- liftIO $ csoundNewOpcodeList' csptr
        case (arrayLen >= 0) of
                True -> do
                        outAry <- liftIO $ peekArray arrayLen ptr
                        return (ptr, outAry)
                False -> throwError $ show ((toEnum arrayLen) :: CsoundStatus)

{#fun unsafe csoundNewOpcodeList as csoundNewOpcodeList'
        {
                id `CsoundPtr',
                alloca- `OpcodeListEntryPtr' peek*
        } -> `Int' #}

csoundDisposeOpcodeList ::
        CsoundPtr
        -> OpcodeListEntryPtr
        -> IO ()
csoundDisposeOpcodeList =
        {#call unsafe csoundDisposeOpcodeList as csoundDisposeOpcodeList_#}

csoundAppendOpcode :: CsoundPtr -- ^Pointer to csound instance
        -> String -- ^Name of opcode to append
        -> Int -- ^dsblksize
        -> Int -- ^thread id
        -> String -- ^outypes
        -> String -- ^intypes
        -> OpcodeFunction -- ^iopadr
        -> OpcodeFunction -- ^kopadr
        -> OpcodeFunction -- ^aopadr
        -> CsoundMonad ()
csoundAppendOpcode csPtr opName dsblksz thread outypes intypes iopadr kopadr aopadr =
        csoundStatusWrapper $ csoundAppendOpcode' csPtr opName dsblksz
          thread outypes intypes iopadr kopadr aopadr

{#fun csoundAppendOpcode as csoundAppendOpcode'
        {
                id `CsoundPtr',
                `String',
                `Int',
                `Int',
                `String',
                `String',
                id `OpcodeFunction',
                id `OpcodeFunction',
                id `OpcodeFunction'
        } -> `CsoundStatus' cIntToEnum#}

-- *Csound library functions.
{#fun csoundOpenLibrary
        {
                alloca- `Ptr ()' peek*,
                `String'
        } -> `Int'#}

{#fun csoundCloseLibrary { id `Ptr ()' } -> `Int'#}

{#fun csoundGetLibrarySymbol
        {
                id `Ptr ()',
                `String'
        } -> `Ptr ()' id#}

-- *Real-time Audio Play and Record
-- **Real-time data types
{#pointer *csRtAudioParams as CsRtAudioParamsPtr -> CsRtAudioParams#}
{#pointer *RTCLOCK as RtClockPtr -> RtClock#}

-- |Real-time audio parameters.
-- The sampleFormat should actually be an enum, as defined in soundio.h.
data CsRtAudioParams = CsRtAudioParams {
        devName :: CString, -- ^ Name of device
        devNum :: Int, -- ^ Device number
        bufSampSW :: Int, -- ^ Software buffer size in sample frames
        bufSampHW :: Int, -- ^ Hardware buffer size in sample frames
        nChannels :: Int, -- ^ Number of channels
        sampleFormat :: Int, -- ^ Sample format (AE_SHORT etc.)
        sampleRate :: Float -- ^ Sample rate in Hz
        }

instance Storable (CsRtAudioParams) where
        --alignment _ = alignment (undefined :: CInt) -- I know there's a better value...
        alignment _ = 16
        sizeOf _ = {#sizeof csRtAudioParams#}
        peek p = do
                dName <- {#get csRtAudioParams.devName#} p
                dNum <- liftM fromIntegral $ {#get csRtAudioParams.devNum#} p
                bufSampSw <- liftM fromIntegral $
                             {#get csRtAudioParams.bufSamp_SW#} p
                bufSampHw <- liftM fromIntegral $
                             {#get csRtAudioParams.bufSamp_HW#} p
                chns <- liftM fromIntegral $ {#get csRtAudioParams.nChannels#} p
                sf <- liftM fromIntegral $
                      {#get csRtAudioParams.sampleFormat#} p
                sr <- liftM (fromRational . toRational) $
                      {#get csRtAudioParams.sampleRate#} p
                return $
                 CsRtAudioParams dName dNum bufSampSw bufSampHw chns sf sr
        poke p params = do
                {#set csRtAudioParams.devName#} p $ devName params
                {#set csRtAudioParams.devNum#} p $ fromIntegral . devNum $
                  params
                {#set csRtAudioParams.bufSamp_SW#} p $
                  fromIntegral . bufSampSW $ params
                {#set csRtAudioParams.bufSamp_HW#} p $
                  fromIntegral . bufSampHW $ params
                {#set csRtAudioParams.nChannels#} p $
                  fromIntegral . nChannels $ params
                {#set csRtAudioParams.sampleFormat#} p $
                  fromIntegral . sampleFormat $ params
                {#set csRtAudioParams.sampleRate#} p $
                  fromRational . toRational . sampleRate $ params

data RtClock = RtClock {
        startTimeReal :: IntLeast64T,
        startTimeCPU :: IntLeast64T
        }

instance Storable (RtClock) where
        alignment _ = alignment (undefined ::CInt)
        sizeOf _ = {#sizeof RTCLOCK#}
        peek p = do
                real <- liftM fromIntegral $ {#get RTCLOCK.starttime_real#} p
                cpu <- liftM fromIntegral $ {#get RTCLOCK.starttime_CPU#} p
                return $ RtClock real cpu
        poke p rt = do
                {#set RTCLOCK.starttime_real#} p $
                  fromIntegral . startTimeReal $ rt
                {#set RTCLOCK.starttime_CPU#} p $
                  fromIntegral . startTimeCPU $ rt

type YieldCallback = FunPtr (CsoundPtr -> IO CInt)

type PlayopenCallback = FunPtr (CsoundPtr -> CsRtAudioParamsPtr -> IO CInt)

type RtplayCallback = FunPtr (CsoundPtr -> Ptr CCsndFlt -> CInt -> IO ())

type RecopenCallback = FunPtr (CsoundPtr -> CsRtAudioParamsPtr -> IO CInt)

type RtrecordCallback = FunPtr (CsoundPtr -> Ptr CCsndFlt -> CInt -> IO CInt)

type RtcloseCallback = FunPtr (CsoundPtr -> IO ())

-- **wrappers to csound real-time audio functions.
csoundSetYieldCallback ::
        CsoundPtr
        -> YieldCallback
        -> IO ()
csoundSetYieldCallback =
        {#call csoundSetYieldCallback as csoundSetYieldCallback_#}

csoundSetPlayopenCallback ::
        CsoundPtr
        -> PlayopenCallback
        -> IO ()
csoundSetPlayopenCallback =
        {#call csoundSetPlayopenCallback as csoundSetPlayopenCallback_#}

csoundSetRtplayCallback ::
        CsoundPtr
        -> RtplayCallback
        -> IO ()
csoundSetRtplayCallback =
        {#call csoundSetRtplayCallback as csoundSetRtplayCallback_#}

csoundSetRecopenCallback ::
        CsoundPtr
        -> RecopenCallback
        -> IO ()
csoundSetRecopenCallback =
        {#call csoundSetRecopenCallback as csoundSetRecopenCallback_#}

csoundSetRtrecordCallback ::
        CsoundPtr
        -> RtrecordCallback
        -> IO ()
csoundSetRtrecordCallback =
        {#call csoundSetRtrecordCallback as csoundSetRtrecordCallback_#}

csoundSetRtcloseCallback ::
        CsoundPtr
        -> RtcloseCallback
        -> IO ()
csoundSetRtcloseCallback =
        {#call unsafe csoundSetRtcloseCallback as csoundSetRtcloseCallback_#}

csoundGetRtRecordUserData :: CsoundPtr -> IO (Ptr (Ptr ()))
csoundGetRtRecordUserData =
        {#call csoundGetRtRecordUserData as csoundGetRtRecordUserData_#}

csoundGetRtPlayUserData :: CsoundPtr -> IO (Ptr (Ptr ()))
csoundGetRtPlayUserData =
        {#call csoundGetRtPlayUserData as csoundGetRtPlayUserData_#}

csoundRegisterSenseEventCallback :: CsoundPtr ->
                                    FunPtr (
                                      CsoundPtr ->
                                      Ptr () ->
                                      IO ()
                                    ) ->
                                    Ptr () ->
                                    CsoundMonad ()
csoundRegisterSenseEventCallback csPtr funPtr dataPtr =
        boolWrapper "RegisterSenseEventCallback failed." $
          csoundRegisterSenseEventCallback' csPtr funPtr dataPtr

{#fun csoundRegisterSenseEventCallback as csoundRegisterSenseEventCallback'
        {
                id `CsoundPtr',
                id `FunPtr (CsoundPtr -> Ptr () -> IO ())',
                id `Ptr ()'
        } -> `Bool' cIntToBoolSwitch#}

{#fun pure unsafe csoundGetDebug { id `CsoundPtr' } -> `Bool' cIntToBool#}

{#fun unsafe csoundSetDebug
        {
                id `CsoundPtr',
                cIntFromEnum `Bool'
        } -> `()'#}

-- *Functions to set and retrieve information from csound function tables.
csoundTableLength :: CsoundPtr -> Int -> CsoundMonad Int
csoundTableLength csPtr tblNum = do
        tableLen <- liftIO $ csoundTableLength' csPtr tblNum
        case (tableLen > 0) of
                True -> return tableLen
                False -> throwError "Table not found."

{#fun unsafe csoundTableLength as csoundTableLength'
        {
                id `CsoundPtr',
                `Int'
        } -> `Int'#}

{#fun unsafe csoundTableGet
        {
                id `CsoundPtr',
                `Int',
                `Int'
        } -> `CsndFlt' cFloatConv#}

{#fun unsafe csoundTableSet
        {
                id `CsoundPtr',
                `Int',
                `Int',
                cFloatConv `CsndFlt'
        } -> `()'#}

csoundGetTable :: CsoundPtr -> Int -> CsoundMonad [CsndFlt]
csoundGetTable csptr tableNum = do
        (arrayLen, ptr) <- liftIO $ csoundGetTable' csptr tableNum
        --Adding 1 to the length to account for the guard point.
        case arrayLen of
                Just val -> liftIO $ peekArray (val+1) ptr
                Nothing -> throwError $
                           "Table " ++ show tableNum ++ " not found."

{#fun unsafe csoundGetTable as csoundGetTable'
        {
                id `CsoundPtr',
                alloca- `Ptr CsndFlt' peekCsndOutAry*,
                `Int'
        } -> `Maybe Int' maybeCInt#}

-- *Csound threading
-- **Threading data types
-- |Signify if a function was able to acquire a mutex object.
data AcquiredMutex =
        AcMutexYes
        | AcMutexNo deriving (Eq)

-- **Csound threading functions
-- |Determine if csoundLockMutexNoWait was successful
mutexSuccessful :: CInt -> AcquiredMutex
mutexSuccessful 0 = AcMutexYes
mutexSuccessful _ = AcMutexNo

csoundCreateThread :: FunPtr (Ptr () -> IO UIntPtrT) -> Ptr () -> IO (Ptr ())
csoundCreateThread =
        {#call csoundCreateThread as csoundCreateThread_#}

csoundGetCurrentThreadId :: IO (Ptr ())
csoundGetCurrentThreadId =
        {#call csoundGetCurrentThreadId as csoundGetCurrentThreadId_#}

csoundJoinThread :: Ptr () -> IO UIntPtrT
csoundJoinThread =
        {#call csoundJoinThread as csoundJoinThread_#}

csoundRunCommand :: [String] -> Bool -> CsoundMonad Int
csoundRunCommand args noWait = do
        output <- liftIO $ csoundRunCommand' args noWait
        if (output < 0) then throwError $ show output
                else return output

{#fun csoundRunCommand as csoundRunCommand'
        {
                withStringList* `[String]',
                cIntFromEnum `Bool'
        } -> `Int'#}

csoundCreateThreadLock :: IO (Ptr ())
csoundCreateThreadLock =
        {#call csoundCreateThreadLock as csoundCreateThreadLock_#}

{#fun csoundWaitThreadLock
        {
                id `Ptr ()' id,
                `Int'
        } -> `Bool' cIntToBool#}

csoundWaitThreadLockNoTimeout :: Ptr () -> IO ()
csoundWaitThreadLockNoTimeout =
        {#call csoundWaitThreadLockNoTimeout as csoundWaitThreadLockNoTimeout_#}

csoundNotifyThreadLock :: Ptr () -> IO ()
csoundNotifyThreadLock =
        {#call csoundNotifyThreadLock as csoundNotifyThreadLock_#}

csoundDestroyThreadLock :: Ptr () -> IO ()
csoundDestroyThreadLock =
        {#call csoundDestroyThreadLock as csoundDestroyThreadLock_#}

csoundCreateMutex :: CInt -> IO (Ptr ())
csoundCreateMutex =
        {#call csoundCreateMutex as csoundCreateMutex_#}

csoundLockMutex :: Ptr () -> IO ()
csoundLockMutex =
        {#call csoundLockMutex as csoundLockMutex_#}

{#fun csoundLockMutexNoWait {id `Ptr ()'}-> `AcquiredMutex' mutexSuccessful#}

csoundUnlockMutex :: Ptr () -> IO ()
csoundUnlockMutex =
        {#call csoundUnlockMutex as csoundUnlockMutex_#}

csoundDestroyMutex :: Ptr () -> IO ()
csoundDestroyMutex =
        {#call csoundDestroyMutex as csoundDestroyMutex_#}

{#fun csoundCreateBarrier {`Int'} -> `Ptr ()' id #}

{#fun csoundDestroyBarrier {id `Ptr ()'} -> `Int'#}

{#fun csoundWaitBarrier {id `Ptr ()'} -> `Int'#}

{#fun unsafe csoundSleep {`Int'} -> `()'#}

-- *Functions to manipulate time\/locale
csoundInitTimerStruct :: IO (RtClockPtr)
csoundInitTimerStruct = do
        ptr <- malloc
        {#call unsafe csoundInitTimerStruct as csoundInitTimerStruct_#} ptr
        return ptr

{#fun pure unsafe csoundGetRealTime { id `RtClockPtr'} -> `Double'#}

{#fun pure unsafe csoundGetCPUTime {id `RtClockPtr'} -> `Double'#}

{#fun unsafe csoundGetRandomSeedFromTime { } -> `UInt32T' cIntConv #}

{#fun unsafe csoundSetLanguage { cIntFromEnum `CsLanguage' } -> `()'#}

{#fun unsafe csoundLocalizeString {`String'} -> `String'#}

-- *Csound global variable manipulations
csoundCreateGlobalVariable :: CsoundPtr -> String -> Int -> CsoundMonad ()
csoundCreateGlobalVariable csPtr name sz = csoundStatusWrapper $
  csoundCreateGlobalVariable' csPtr name sz

{#fun unsafe csoundCreateGlobalVariable as csoundCreateGlobalVariable'
        {
                id `CsoundPtr',
                `String',
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

csoundQueryGlobalVariable :: CsoundPtr -> String -> CsoundMonad (Ptr ())
csoundQueryGlobalVariable csPtr name = do
        maybePtr <- liftIO $ csoundQueryGlobalVariable' csPtr name
        case maybePtr of
                Just val -> return val
                Nothing -> throwError $
                           "Global variable " ++ name ++ " not found."

{#fun unsafe csoundQueryGlobalVariable as csoundQueryGlobalVariable'
        {
                id `CsoundPtr',
                `String'
        } -> `Maybe (Ptr ())' checkNullPtr#}

-- |Even if the returned pointer is not null, it may not be a valid
-- pointer if the name was invalid.
{#fun unsafe csoundQueryGlobalVariableNoCheck as
  csoundQueryGlobalVariableNoCheck'
        {
                id `CsoundPtr',
                `String'
        } -> `Ptr ()' id#}

csoundDestroyGlobalVariable :: CsoundPtr -> String -> CsoundMonad ()
csoundDestroyGlobalVariable csPtr name = csoundStatusWrapper $
  csoundDestroyGlobalVariable' csPtr name

{#fun unsafe csoundDestroyGlobalVariable as csoundDestroyGlobalVariable'
        {
                id `CsoundPtr',
                `String'
        } -> `CsoundStatus' cIntToEnum#}

{#fun pure unsafe csoundGetSizeOfMYFLT {} -> `Int'#}


-- *Csound utility functions
csoundRunUtility :: CsoundPtr -> String -> String -> CsoundMonad ()
csoundRunUtility csPtr name args = boolWrapper errStr $
  csoundRunUtility' csPtr name argv argc
        where
        errStr = "Attempt to run utility " ++ name ++ " failed."
        argc = words args
        argv = length argc

{#fun csoundRunUtility as csoundRunUtility'
        {
                id `CsoundPtr',
                `String',
                `Int',
                withStringList* `[String]'
        } -> `Bool' cIntToBoolSwitch#}

csoundListUtilities :: CsoundPtr -> CsoundMonad (Ptr CString, [String])
csoundListUtilities csPtr = liftIO $ unsafeCsoundListUtilities csPtr

{#fun unsafe csoundListUtilities as unsafeCsoundListUtilities
        {
                id `CsoundPtr'
        } -> `(Ptr CString, [String])' peekStringArrayPtr*#}

csoundDeleteUtilityList :: CsoundPtr -> Ptr (Ptr CChar) -> IO ()
csoundDeleteUtilityList =
        {#call unsafe csoundDeleteUtilityList as uCsoundDeleteUtilityList_#}

{#fun pure unsafe csoundGetUtilityDescription
        {
                id `CsoundPtr',
                `String'
        } -> `String'#}

-- *Csound channel functions
-- **Channel data types
{#pointer *CsoundChannelListEntry as
  CsoundChannelListEntryPtr -> CsoundChannelListEntry#}
{#pointer CsoundChannelIOCallback_t as CsoundChannelIOCallbackT#}

data CsoundChannelListEntry = CsoundChannelListEntry
        {
        cliName :: CString, -- ^Name of Csound channel
        cliType :: Int -- ^Type of Csound channel
        }
-- Can't use the hooks for names with type in them :(
instance Storable (CsoundChannelListEntry) where
        alignment _ = alignment (undefined :: CInt)
        sizeOf _ = {#sizeof CsoundChannelListEntry#}
        peek p = do
                cliname <- {#get CsoundChannelListEntry.name#} p
                cliTypeV <- liftM fromIntegral $
                            (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) p
                return $ CsoundChannelListEntry cliname cliTypeV
        poke p cli = do
                {#set CsoundChannelListEntry.name#} p $ cliName cli
                (\ptr val -> do {pokeByteOff ptr 4 (val::CInt)}) p $
                  fromIntegral $ cliType cli

-- |Type of a channel
data CsoundChannelType =
        CsoundControlChannel
        | CsoundAudioChannel
        | CsoundStringChannel deriving (Eq, Show)
instance Enum CsoundChannelType where
        fromEnum CsoundControlChannel = 1
        fromEnum CsoundAudioChannel = 2
        fromEnum CsoundStringChannel = 3

        toEnum 1 = CsoundControlChannel
        toEnum 2 = CsoundAudioChannel
        toEnum 3 = CsoundStringChannel
        toEnum unmatched = error
                  ("CsoundChannelType.toEnum: Cannot match " ++ show unmatched)

-- |Direction of a channel
data CsoundChannelDirection =
        CsoundInputChannel
        | CsoundOutputChannel
        | CsoundBiDirectionalChannel deriving (Eq, Show)
instance Enum CsoundChannelDirection where
        fromEnum CsoundInputChannel = 16
        fromEnum CsoundOutputChannel = 32
        fromEnum CsoundBiDirectionalChannel = 48

        toEnum 16 = CsoundInputChannel
        toEnum 32 = CsoundOutputChannel
        toEnum 48 = CsoundBiDirectionalChannel
        toEnum unmatched = error
          ("CsoundChannelDirection.toEnum: Cannot match " ++ show unmatched)

-- |Specify both direction and type of a channel.
data CsoundChannelDirectionalType =
        CsoundChannelDirectionalType CsoundChannelType CsoundChannelDirection
        deriving (Eq, Show)

-- |Specify the type of a control channel.
data CsoundControlChannelType =
        CsoundControlChannelClear
        | CsoundControlChannelInt
        | CsoundControlChannelLin
        | CsoundControlChannelExp
        deriving (Eq, Show)
instance Enum CsoundControlChannelType where
        fromEnum CsoundControlChannelClear = 0
        fromEnum CsoundControlChannelInt = 1
        fromEnum CsoundControlChannelLin = 2
        fromEnum CsoundControlChannelExp = 3

        toEnum 0 = CsoundControlChannelClear
        toEnum 1 = CsoundControlChannelInt
        toEnum 2 = CsoundControlChannelLin
        toEnum 3 = CsoundControlChannelExp
        toEnum unmatched = error
          ("CsoundControlChannelType.toEnum: Cannot match " ++ show unmatched)

-- |Status of ListChannels return value
data CsoundListChannelStatus =
        NumChannels Int
        | ChanError CsoundStatus

-- |Decode channel information
decodeChannelInfo :: CInt -> (CsoundChannelType, CsoundChannelDirection)
decodeChannelInfo val = (chanType, chanDir)
        where
        chanType = toEnum $ (.&.) 15 $ cIntConv val
        chanDir = case (testBit val 5, testBit val 6) of
                (True, False) -> CsoundInputChannel
                (False, True) -> CsoundOutputChannel
                (True, True) -> CsoundBiDirectionalChannel
                _ -> error "Invalid channel direction."

toChannelListStatus :: CInt -> CsoundListChannelStatus
toChannelListStatus val = case (val >= 0) of
        True -> NumChannels $ cIntConv val
        False -> ChanError $ cIntToEnum val

csoundChannelDirectionalTypeToCInt :: CsoundChannelDirectionalType -> CInt
csoundChannelDirectionalTypeToCInt (CsoundChannelDirectionalType typ dir) =
        fromIntegral $ (fromEnum typ) .|. (fromEnum dir)

-- **Functions for the 'chan' family of opcodes
csoundGetChannelPtr :: CsoundPtr ->
                       String ->
                       CsoundChannelDirectionalType ->
                       CsoundMonad (Ptr CsndFlt)
csoundGetChannelPtr csPtr name chantype = do
        res <- liftIO $ csoundGetChannelPtr' csPtr name chantype
        case res of
                (CsoundSuccess, myPtr) -> return myPtr
                (err, _) -> throwError $ "Error '" ++ show err ++
                  "' getting channel pointer " ++ name ++ "."

{#fun unsafe csoundGetChannelPtr as csoundGetChannelPtr'
        {
                id `CsoundPtr',
                alloca- `Ptr CsndFlt' peekCsndOutAry*,
                `String',
                csoundChannelDirectionalTypeToCInt
                  `CsoundChannelDirectionalType'
        } -> `CsoundStatus' cIntToEnum#}

csoundListChannels :: CsoundPtr ->
                      CsoundMonad (CsoundChannelListEntryPtr,
                        [CsoundChannelListEntry])
csoundListChannels csPtr = do
        (arrayLen, ptr) <- liftIO $ csoundListChannels' csPtr
        case arrayLen of
                NumChannels 0 -> return (ptr, [])
                NumChannels nC -> do
                        vals <- liftIO $ peekArray nC ptr
                        return (ptr, vals)
                ChanError err -> throwError $ show err

{#fun unsafe csoundListChannels as csoundListChannels'
        {
                id `CsoundPtr',
                alloca- `CsoundChannelListEntryPtr' peek*
        } -> `CsoundListChannelStatus' toChannelListStatus#}

csoundDeleteChannelList :: CsoundPtr -> CsoundChannelListEntryPtr -> IO ()
csoundDeleteChannelList =
        {#call unsafe csoundDeleteChannelList as csoundDeleteChannelList_#}

csoundSetControlChannelParams ::
        CsoundPtr -- ^Pointer to Csound instance.
        -> String -- ^Name of channel to write to
        -> CsoundControlChannelType -- ^Type of channel
        -> CsndFlt -- ^Default value for channel
        -> CsndFlt -- ^Minimum value for channel
        -> CsndFlt -- ^Maximum value for channel
        -> CsoundMonad ()
csoundSetControlChannelParams csPtr chanName chanType defVal minVal maxVal =
        csoundStatusWrapper $ csoundSetControlChannelParams' csPtr chanName
          chanType defVal minVal maxVal
{#fun unsafe csoundSetControlChannelParams as csoundSetControlChannelParams'
        {
                id `CsoundPtr',
                `String',
                cIntFromEnum `CsoundControlChannelType',
                cFloatConv `CsndFlt',
                cFloatConv `CsndFlt',
                cFloatConv `CsndFlt'
        } -> `CsoundStatus' cIntToEnum#}

-- |Query a control channel to get special parameters (as specified by
-- csoundSetControlChannelParams).  If the channel exists and the params
-- are set, the type of the control channel, default, minimum and
-- maximum are returned.  If the control channel exists but no special params
-- are defined, this function will have a value of Nothing.
-- Otherwise the error code will be specified in CsoundMonad.
csoundGetControlChannelParams ::
        CsoundPtr -- ^Pointer to this csound instance
        -> String -- ^Name of channel to query
        -> CsoundMonad (Maybe (CsoundControlChannelType, CsndFlt,
             CsndFlt, CsndFlt))
csoundGetControlChannelParams csPtr chanName = do
        (typ, d, mn, mx) <- liftIO $
                            csoundGetControlChannelParams' csPtr chanName
        case (typ < 0, toEnum typ) of
                (True, _) -> throwError $
                             "csoundGetControlChannelParams returned error " ++
                             show typ
                (False, CsoundControlChannelClear) -> return Nothing
                (False, realTyp) -> return $ Just (realTyp, d, mn, mx)

{#fun unsafe csoundGetControlChannelParams as csoundGetControlChannelParams'
        {
                id `CsoundPtr',
                `String',
                alloca- `CsndFlt' peekCsndFlt*,
                alloca- `CsndFlt' peekCsndFlt*,
                alloca- `CsndFlt' peekCsndFlt*
        } -> `Int'#}

csoundSetChannelIOCallback :: CsoundPtr -> CsoundChannelIOCallbackT -> IO ()
csoundSetChannelIOCallback =
        {#call csoundSetChannelIOCallback as csoundSetChannelIOCallback_#}

-- **functions for the 'ichannel' family of opcodes
csoundChanIKSet :: CsoundPtr -- ^Pointer to this csound instance
        -> CsndFlt -- ^Value to set
        -> Int -- ^Channel number to access.
        -> CsoundMonad ()
csoundChanIKSet csPtr val chan = csoundStatusWrapper $
                                 csoundChanIKSet' csPtr val chan

{#fun unsafe csoundChanIKSet as csoundChanIKSet'
        {
                id `CsoundPtr',
                cFloatConv `CsndFlt',
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

csoundChanOKGet :: CsoundPtr -- ^Pointer to this csound instance
        -> Int -- ^Index of channel
        -> CsoundMonad CsndFlt -- ^current value of the channel
csoundChanOKGet csPtr chan = csoundStatValWrapper $ csoundChanOKGet' csPtr chan

{#fun unsafe csoundChanOKGet as csoundChanOKGet'
        {
                id `CsoundPtr',
                alloca- `CsndFlt' peekCsndFlt*,
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

csoundChanIASet :: CsoundPtr -- ^Pointer to this csound instance.
        -> [CsndFlt] -- ^Array of value (of length ksmps) to write to a channel
        -> Int -- ^Index of channel
        -> CsoundMonad ()
csoundChanIASet csPtr ary chan = csoundStatusWrapper $
                                 csoundChanIASet' csPtr ary chan

{#fun unsafe csoundChanIASet as csoundChanIASet'
        {
                id `CsoundPtr',
                withCsndFltArray* `[CsndFlt]',
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

-- |TODO: Possible bug- it's likely that a buffer ksmps long will need to be
-- allocated, instead of
-- the single pointer actually allocated within unsafeCsoundChanOAGet
csoundChanOAGet :: CsoundPtr -- ^Pointer to this csound instance.
        -> Int -- ^Length of audio array (ksmps)
        -> Int -- ^Index of channel
        -> CsoundMonad [CsndFlt]
csoundChanOAGet csPtr len chan = do
        (stat, ptr) <- liftIO $ unsafeCsoundChanOAGet csPtr chan
        case (stat) of
                CsoundSuccess -> liftIO $ fmap (map cFloatConv) $ peekArray
                                 len ptr
                err -> throwError $ show err

{#fun unsafe csoundChanOAGet as unsafeCsoundChanOAGet
        {
                id `CsoundPtr',
                alloca- `Ptr CCsndFlt' id,
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

-- **Functions for PvsIn and PvsOut
csoundPvsinSet :: CsoundPtr -- ^Pointer to this csound instance.
        -> PvsDatExt -- ^PvsDatExt object to send
        -> Int -- ^Index of channel
        -> CsoundMonad ()
csoundPvsinSet csPtr pvs chan = csoundStatusWrapper $
                                unsafeCsoundPvsinSet csPtr pvs chan

{#fun unsafe csoundPvsinSet as unsafeCsoundPvsinSet
        {
                id `CsoundPtr',
                withObject* `PvsDatExt',
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

csoundPvsoutGet :: CsoundPtr -- ^Pointer to this csound instance
        -> Int -- ^Index of channel
        -> CsoundMonad PvsDatExt
csoundPvsoutGet csPtr chan = csoundStatValWrapper $
                             unsafeCsoundPvsoutGet csPtr chan

{#fun unsafe csoundPvsoutGet as unsafeCsoundPvsoutGet
        {
                id `CsoundPtr',
                alloca- `PvsDatExt' peek*,
                `Int'
        } -> `CsoundStatus' cIntToEnum#}

-- *Csound randomization functions.
-- **Randomization state data types
-- |This uses some pointer magic, there's a good chance that there
-- are bugs in the Storable instance.
data CsoundRandMtState = CsoundRandMtState {
        mti :: Int,
        mt :: [UInt32T]
        }
instance Storable (CsoundRandMtState) where
        alignment _ = alignment (undefined :: CInt)
        sizeOf _ = {#sizeof CsoundRandMTState#}
        peek p = do
                mtiV <- liftM fromIntegral $ {#get CsoundRandMTState.mti#} p
                aryPtr <- {#get CsoundRandMTState.mt#} p
                mtV <- peekArray 624 aryPtr
                return $ CsoundRandMtState mtiV mtV
        poke p mtstate = do
                {#set CsoundRandMTState.mti#} p $ fromIntegral . mti $ mtstate
                let aryPtr = plusPtr p $ sizeOf (1 :: CInt)
                pokeArray aryPtr $ mt mtstate

-- **Csound functions
{#fun pure unsafe csoundRand31
        {
                `Int'
        } -> `Int'#}
{-
   * Initialise Mersenne Twister (MT19937) random number generator,
   * using 'keyLength' unsigned 32 bit values from 'initKey' as seed.
   * If the array is NULL, the length parameter is used for seeding.
   */
  PUBLIC void csoundSeedRandMT(CsoundRandMTState *p,
                               const uint32_t *initKey, uint32_t keyLength);

  /**
   * Returns next random number from MT19937 generator.
   * The PRNG must be initialised first by calling csoundSeedRandMT().
   */
  PUBLIC uint32_t csoundRandMT(CsoundRandMTState *p);
-}

-- *Csound generic callback functions
type CsoundCallbackFunction = FunPtr (Ptr () -> Ptr () -> CUInt -> IO CInt)

csoundSetCallback :: CsoundPtr -- ^Pointer to this csound instance.
        -> CsoundCallbackFunction -- ^Callback function
        -> Ptr () -- ^Pointer to "userdata"
        -> CsoundCallbackFunctionTypeMask
        -> CsoundMonad CsoundSetCallbackStatus
csoundSetCallback csPtr fnPtr dataPtr typeMask = do
        res <- liftIO $ fmap  cIntToSetCallbackStatus $
                {#call csoundSetCallback as csoundSetCallback_#} csPtr
                fnPtr dataPtr $ cIntConv typeMask
        case res of
                SetCallbackOk -> return SetCallbackOk
                err -> throwError $ show err

csoundRemoveCallback ::
        CsoundPtr
        -> CsoundCallbackFunction
        -> IO ()
csoundRemoveCallback =
        {#call csoundRemoveCallback as csoundRemoveCallback_#}

-- *Csound messaging functions
csoundEnableMessageBuffer :: CsoundPtr -> Int -> IO ()
csoundEnableMessageBuffer csPtr toStdOut =
        {#call csoundEnableMessageBuffer as csoundEnableMessageBuffer_#}
        csPtr $ cIntConv toStdOut

{#fun csoundGetFirstMessage { id `CsoundPtr'} -> `String'#}

csoundGetFirstMessageAttr :: CsoundPtr -> IO Int
csoundGetFirstMessageAttr csPtr =
        liftM cIntConv $ {#call csoundGetFirstMessageAttr as
          csoundGetFirstMessageAttr_#} csPtr

csoundPopFirstMessage :: CsoundPtr -> IO ()
csoundPopFirstMessage = {#call csoundPopFirstMessage as csoundPopFirstMessage_#}

csoundGetMessageCnt :: CsoundPtr -> Int
csoundGetMessageCnt csPtr =
        cIntConv $ {#call pure unsafe csoundGetMessageCnt as
          csoundGetMessageCnt_#} csPtr

csoundDestroyMessageBuffer :: CsoundPtr -> IO ()
csoundDestroyMessageBuffer csPtr =
        {#call csoundDestroyMessageBuffer as csoundDestroyMessageBuffer_#} csPtr

-- |Not doing sigcpy now, it looks like a utility function and I don't know
-- if I'll need it.

#if !defined(SWIG)
type CsoundFileOpenCallback = FunPtr (CsoundPtr -> CString -> CInt -> CInt -> CInt -> IO ())
csoundSetFileOpenCallback ::
        CsoundPtr
        -> CsoundFileOpenCallback
        -> IO ()
csoundSetFileOpenCallback csPtr funPtr =
        {#call unsafe csoundSetFileOpenCallback as csoundSetFileOpenCallback_#} csPtr funPtr
#endif