{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, TypeFamilies #-} -- |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.Foreign where import Control.Applicative import Control.Monad (liftM) import Control.Monad.IO.Class import Control.Monad.Error.Class import Control.Monad.Trans.Error (ErrorT) import Control.Monad.Reader import qualified Control.Monad.Trans.Cont as Cont import Data.Bits import Data.List ( foldl') import Foreign.C import Foreign.C.Types import Foreign #include -- **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#} -- **Csound error type data CsoundError = CsString String | CsStatus CsoundStatus deriving (Show, Eq) instance Error CsoundError where strMsg = CsString -- **The Csound and associated functions newtype Csound a = Stack { unStack :: ReaderT CsoundPtr (ErrorT CsoundError IO) a } deriving (Monad, Functor, MonadIO, Applicative) instance MonadError Csound where type ErrorType Csound = CsoundError throwError e = Stack (lift $ throwError e) catchError m f = Stack $ catchError (unStack m) (unStack . f) instance MonadReader Csound where type EnvType Csound = CsoundPtr ask = Stack ask local f = Stack . local f . unStack -- |Wrap functions that return CsoundStatus into the Csound -- for error handling csoundStatusWrapper :: IO CsoundStatus -> Csound () csoundStatusWrapper csoundFunc = do res <- liftIO csoundFunc case res of CsoundSuccess -> return () _ -> throwError $ CsStatus res -- |Wrap functions that return a CsoundStatus and one other value into the -- Csound for error handling. csoundStatValWrapper :: IO (CsoundStatus, a) -> Csound a csoundStatValWrapper func = do (stat, output) <- liftIO func case stat of CsoundSuccess -> return output _ -> throwError (CsStatus stat) >> return output -- |Wrap functions that return CsoundPerformStatus into the Csound. csPerformStatusWrapper :: IO CsoundPerformStatus -> Csound CsoundPerformStatus csPerformStatusWrapper csoundFunc = do res <- liftIO csoundFunc case res of PerformError stat -> throwError $ CsStatus stat _ -> return res -- |Wrap any function from IO monad to Csound csoundWrapper :: (a -> IO b) -> a -> Csound b csoundWrapper fn v = liftIO $ fn v {-# INLINE csoundWrapper #-} -- |Wrap functions that return Bool into the Csound boolWrapper :: String -> IO Bool -> Csound () boolWrapper errStr action = do res <- liftIO action case res of True -> return () False -> throwError $ CsString 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 i = error ("CsoundInit.toEnum: Cannot match " ++ show i) -- |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 cIntConv :: (Integral a, Num b) => a -> b cIntConv = fromIntegral cFloatConv :: (Real a, Fractional b) => a -> b cFloatConv = realToFrac withIntConv :: Int -> (Ptr CInt -> IO b) -> IO b withIntConv i f = alloca (\p -> poke p (fromIntegral i) >> f p) peekIntConv = fmap fromIntegral . peek -- |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 0 = False cIntToBool _ = 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 0 = True cIntToBoolSwitch _ = 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 | val < 0 = SetCallbackError $ cIntToEnum val | otherwise = 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 :: Monad m => [(r -> m a) -> m a] -> ([r] -> m a) -> m a nest xs = Cont.runContT (sequence (map Cont.ContT 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 = liftM cFloatConv . peek -- |Marshal a Ptr (Ptr CCsndFlt) to a Ptr (CCsndFlt). peekCsndOutAry :: Ptr (Ptr CCsndFlt) -> IO (Ptr CCsndFlt) peekCsndOutAry ptrPtr = peek ptrPtr -- |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'#} -} unsafeCsoundCreate :: Ptr () -> IO (CsoundPtr) unsafeCsoundCreate = {#call unsafe csoundCreate as uCsoundCreate'#} {#fun unsafe csoundPreCompile as unsafeCsoundPreCompile {id `CsoundPtr'} -> `CsoundStatus' cIntToEnum #} {#fun unsafe csoundInitializeCscore as unsafeCsoundInitializeCscore { id `CsoundPtr', id `FilePtr', id `FilePtr' } -> `CsoundStatus' cIntToEnum#} -- |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#} {#fun unsafe csoundGetVersion as getVersion' {} -> `Int'#} {#fun unsafe csoundGetAPIVersion as getApiVersion' {} -> `Int'#} destroy' :: CsoundPtr -> IO () destroy' = {#call unsafe csoundDestroy #} getHostData' :: CsoundPtr -> IO (Ptr ()) getHostData' = {#call csoundGetHostData #} setHostData' :: CsoundPtr -> Ptr () -> IO () setHostData' = {#call csoundSetHostData #} {#fun csoundGetEnv as getEnv' {id `CsoundPtr', `String'} -> `String'#} {#fun csoundSetGlobalEnv as setGlobalEnv' {`String', `String'} -> `CsoundStatus' cIntToEnum#} -- *Performance functions {#fun unsafe csoundCompile as compile' { id `CsoundPtr', `Int', withStringList* `[String]' } -> `CsoundStatus' cIntToEnum#} {#fun csoundPerform as perform' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#} {#fun csoundPerformKsmps as performKsmps' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#} {#fun unsafe csoundPerformKsmps as unsafePerformKsmps' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#} {#fun csoundPerformKsmpsAbsolute as performKsmpsAbsolute' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#} {#fun csoundPerformBuffer as performBuffer' {id `CsoundPtr'} -> `CsoundPerformStatus' toCsoundPerformStatus#} {#fun csoundStop as stop' {id `CsoundPtr'} -> `()'#} {#fun csoundCleanup as cleanup' {id `CsoundPtr'} -> `Int'#} {#fun csoundReset as reset' {id `CsoundPtr'} -> `()'#} -- *Csound Attributes {#fun unsafe csoundGetSr as getSr' { id `CsoundPtr'} -> `CsndFlt' cFloatConv#} {#fun unsafe csoundGetKr as getKr' { id `CsoundPtr'} -> `CsndFlt' cFloatConv#} {#fun unsafe csoundGetKsmps as getKsmps' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundGetNchnls as getNchnls' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundGet0dBFS as get0dBFS' { id `CsoundPtr'} -> `CsndFlt' cFloatConv#} {#fun unsafe csoundGetStrVarMaxLen as getStrVarMaxLen' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundGetSampleFormat as getSampleFormat' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundGetSampleSize as getSampleSize' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundGetInputBufferSize as getInputBufferSize' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundGetOutputBufferSize as getOutputBufferSize' { 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 getInputBuffer' { id `CsoundPtr'} -> `Ptr CsndFlt' castPtr#} {#fun unsafe csoundGetOutputBuffer as getOutputBuffer' { id `CsoundPtr'} -> `Ptr CsndFlt' castPtr#} {#fun unsafe csoundGetSpin as getSpin' { id `CsoundPtr'} -> `Ptr CsndFlt' castPtr#} {#fun unsafe csoundGetSpout as getSpout' { id `CsoundPtr'} -> `Ptr CsndFlt' castPtr#} {#fun unsafe csoundGetOutputFileName as getOutputFileName' { id `CsoundPtr'} -> `String'#} -- |Call between csoundPreCompile and csoundCompile to set Host Implemented IO {#fun unsafe csoundSetHostImplementedAudioIO as setHostImplementedAudioIO' { id `CsoundPtr', `Int', `Int' } -> `()'#} -- *Score handling functions. {#fun unsafe csoundGetScoreTime as getScoreTime' { id `CsoundPtr'} -> `CsndFlt' cFloatConv#} {#fun unsafe csoundIsScorePending as isScorePending' { id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundSetScorePending as setScorePending' { id `CsoundPtr', `Int' } -> `()'#} {#fun unsafe csoundGetScoreOffsetSeconds as getScoreOffsetSeconds' { id `CsoundPtr'} -> `CsndFlt' cFloatConv#} {#fun unsafe csoundSetScoreOffsetSeconds as setScoreOffsetSeconds' { id `CsoundPtr', cFloatConv `CsndFlt' } -> `()'#} rewindScore' :: CsoundPtr -> IO () rewindScore' = {#call csoundRewindScore #} setCscoreCallback' :: CsoundPtr -> FunPtr (CsoundPtr -> IO ()) -> IO () setCscoreCallback' = {#call csoundSetCscoreCallback #} {#fun csoundScoreSort as scoreSort' { id `CsoundPtr', id `FilePtr', id `FilePtr' } -> `CsoundStatus' cIntToEnum#} {#fun csoundScoreExtract as scoreExtract' { id `CsoundPtr', id `FilePtr', id `FilePtr', id `FilePtr' } -> `CsoundStatus' cIntToEnum#} -- *Messages and Text {#fun unsafe csoundGetMessageLevel as getMessageLevel' {id `CsoundPtr'} -> `Int'#} {#fun unsafe csoundSetMessageLevel as setMessageLevel' { id `CsoundPtr', `Int' } -> `()'#} {#fun unsafe csoundInputMessage as inputMessage' { id `CsoundPtr', `String' } -> `()'#} {#fun csoundKeyPress as keyPress' { 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. setInputValueCallback' :: CsoundPtr -> InputValueCallback -> IO () setInputValueCallback' = {#call csoundSetInputValueCallback #} -- |called by 'outvalue' opcode. setOutputValueCallback' :: CsoundPtr -> OutputValueCallback -> IO () setOutputValueCallback' = {#call csoundSetOutputValueCallback #} {#fun csoundScoreEvent as scoreEvent' { 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 setExternalMidiInOpenCallback' :: CsoundPtr -> ExternalMidiOpenCallback -> IO () setExternalMidiInOpenCallback' = {#call csoundSetExternalMidiInOpenCallback #} setExternalMidiReadCallback' :: CsoundPtr -> ExternalMidiReadCallback -> IO () setExternalMidiReadCallback' = {#call csoundSetExternalMidiReadCallback #} setExternalMidiInCloseCallback' :: CsoundPtr -> ExternalMidiCloseCallback -> IO () setExternalMidiInCloseCallback' = {#call csoundSetExternalMidiInCloseCallback #} setExternalMidiOutOpenCallback' :: CsoundPtr -> ExternalMidiOpenCallback -> IO () setExternalMidiOutOpenCallback' = {#call csoundSetExternalMidiOutOpenCallback #} setExternalMidiWriteCallback' :: CsoundPtr -> ExternalMidiWriteCallback -> IO () setExternalMidiWriteCallback' = {#call csoundSetExternalMidiWriteCallback #} setExternalMidiOutCloseCallback' :: CsoundPtr -> ExternalMidiCloseCallback -> IO () setExternalMidiOutCloseCallback' = {#call csoundSetExternalMidiOutCloseCallback #} setExternalMidiErrorStringCallback' :: CsoundPtr -> ExternalMidiErrorStringCallback -> IO () setExternalMidiErrorStringCallback' = {#call 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 as setIsGraphable' {id `CsoundPtr', `Int' } -> `Int'#} setMakeGraphCallback' :: CsoundPtr -> MakeGraphCallback -> IO () setMakeGraphCallback' = {#call csoundSetMakeGraphCallback #} setDrawGraphCallback' :: CsoundPtr -> DrawGraphCallback -> IO () setDrawGraphCallback' = {#call csoundSetDrawGraphCallback #} setKillGraphCallback' :: CsoundPtr -> KillGraphCallback -> IO () setKillGraphCallback' = {#call csoundSetKillGraphCallback #} setMakeXYinCallback' :: CsoundPtr -> MakeXYinCallback -> IO () setMakeXYinCallback' = {#call csoundSetMakeXYinCallback #} setReadXYinCallback' :: CsoundPtr -> ReadXYinCallback -> IO () setReadXYinCallback' = {#call csoundSetReadXYinCallback #} setKillXYinCallback' :: CsoundPtr -> KillXYinCallback -> IO () setKillXYinCallback' = {#call csoundSetKillXYinCallback #} setExitGraphCallback' :: CsoundPtr -> ExitGraphCallback -> IO () setExitGraphCallback' = {#call csoundSetExitGraphCallback #} -- *Csound opcodes -- **Opcode data types {#pointer *opcodeListEntry as OpcodeListEntryPtr -> OpcodeListEntry#} data OpcodeListEntry = OpcodeListEntry { opcodeName :: String, -- ^Name of opcode ouTypes :: String, -- ^Output types inTypes :: String -- ^Input types } deriving (Eq, Show) instance Storable (OpcodeListEntry) where alignment _ = 16 sizeOf _ = {#sizeof opcodeListEntry#} peek p = do nameV <- {#get opcodeListEntry.opname#} p >>= peekCString otypesV <- {#get opcodeListEntry.outypes#} p >>= peekCString itypesV <- {#get opcodeListEntry.intypes#} p >>= peekCString return $ OpcodeListEntry nameV otypesV itypesV poke p li = do newCString (opcodeName li) >>= {#set opcodeListEntry.opname#} p newCString (ouTypes li) >>= {#set opcodeListEntry.outypes#} p newCString (inTypes li) >>= {#set opcodeListEntry.intypes#} p -- **opcode function types -- |Type for a callback function of a new csound opcode. type OpcodeFunction = FunPtr (CsoundPtr -> Ptr () -> IO CInt) -- **Csound opcode manipulation functions {#fun unsafe csoundNewOpcodeList as newOpcodeList' { id `CsoundPtr', alloca- `OpcodeListEntryPtr' peek* } -> `Int' #} disposeOpcodeList' :: CsoundPtr -> OpcodeListEntryPtr -> IO () disposeOpcodeList' = {#call unsafe csoundDisposeOpcodeList #} {#fun csoundAppendOpcode as appendOpcode' { id `CsoundPtr', `String', `Int', `Int', `String', `String', id `OpcodeFunction', id `OpcodeFunction', id `OpcodeFunction' } -> `CsoundStatus' cIntToEnum#} -- *Csound library functions. {#fun csoundOpenLibrary as openLibrary' { alloca- `Ptr ()' peek*, `String' } -> `Int'#} {#fun csoundCloseLibrary as closeLibrary' { id `Ptr ()' } -> `Int'#} {#fun csoundGetLibrarySymbol as getLibrarySymbol' { 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 _ = 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. setYieldCallback' :: CsoundPtr -> YieldCallback -> IO () setYieldCallback' = {#call csoundSetYieldCallback #} setPlayopenCallback' :: CsoundPtr -> PlayopenCallback -> IO () setPlayopenCallback' = {#call csoundSetPlayopenCallback #} setRtplayCallback' :: CsoundPtr -> RtplayCallback -> IO () setRtplayCallback' = {#call csoundSetRtplayCallback #} setRecopenCallback' :: CsoundPtr -> RecopenCallback -> IO () setRecopenCallback' = {#call csoundSetRecopenCallback #} setRtrecordCallback' :: CsoundPtr -> RtrecordCallback -> IO () setRtrecordCallback' = {#call csoundSetRtrecordCallback #} setRtcloseCallback' :: CsoundPtr -> RtcloseCallback -> IO () setRtcloseCallback' = {#call unsafe csoundSetRtcloseCallback #} getRtRecordUserData' :: CsoundPtr -> IO (Ptr (Ptr ())) getRtRecordUserData' = {#call csoundGetRtRecordUserData #} getRtPlayUserData' :: CsoundPtr -> IO (Ptr (Ptr ())) getRtPlayUserData' = {#call csoundGetRtPlayUserData #} {#fun csoundRegisterSenseEventCallback as registerSenseEventCallback' { id `CsoundPtr', id `FunPtr (CsoundPtr -> Ptr () -> IO ())', id `Ptr ()' } -> `Bool' cIntToBoolSwitch#} {#fun unsafe csoundGetDebug as getDebug' { id `CsoundPtr' } -> `Bool' cIntToBool#} {#fun unsafe csoundSetDebug as setDebug' { id `CsoundPtr', cIntFromEnum `Bool' } -> `()'#} -- *Functions to set and retrieve information from csound function tables. {#fun unsafe csoundTableLength as tableLength' { id `CsoundPtr', `Int' } -> `Int'#} {#fun unsafe csoundTableGet as tableGet' { id `CsoundPtr', `Int', `Int' } -> `CsndFlt' cFloatConv#} {#fun unsafe csoundTableSet as tableSet' { id `CsoundPtr', `Int', `Int', cFloatConv `CsndFlt' } -> `()'#} {#fun unsafe csoundGetTable as getTable' { id `CsoundPtr', alloca- `Ptr CCsndFlt' 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 createThread' :: FunPtr (Ptr () -> IO UIntPtrT) -> Ptr () -> IO (Ptr ()) createThread' = {#call csoundCreateThread #} getCurrentThreadId' :: IO (Ptr ()) getCurrentThreadId' = {#call csoundGetCurrentThreadId #} joinThread' :: Ptr () -> IO UIntPtrT joinThread' = {#call csoundJoinThread #} {#fun csoundRunCommand as runCommand' { withStringList* `[String]', cIntFromEnum `Bool' } -> `Int'#} createThreadLock' :: IO (Ptr ()) createThreadLock' = {#call csoundCreateThreadLock #} {#fun csoundWaitThreadLock as waitThreadLock' { id `Ptr ()' id, `Int' } -> `Bool' cIntToBool#} waitThreadLockNoTimeout' :: Ptr () -> IO () waitThreadLockNoTimeout' = {#call csoundWaitThreadLockNoTimeout #} notifyThreadLock' :: Ptr () -> IO () notifyThreadLock' = {#call csoundNotifyThreadLock #} destroyThreadLock' :: Ptr () -> IO () destroyThreadLock' = {#call csoundDestroyThreadLock #} createMutex' :: CInt -> IO (Ptr ()) createMutex' = {#call csoundCreateMutex #} lockMutex' :: Ptr () -> IO () lockMutex' = {#call csoundLockMutex #} {#fun csoundLockMutexNoWait as lockMutexNoWait' {id `Ptr ()'}-> `AcquiredMutex' mutexSuccessful#} unlockMutex' :: Ptr () -> IO () unlockMutex' = {#call csoundUnlockMutex #} destroyMutex' :: Ptr () -> IO () destroyMutex' = {#call csoundDestroyMutex #} {#fun csoundCreateBarrier as createBarrier' {`Int'} -> `Ptr ()' id #} {#fun csoundDestroyBarrier as destroyBarrier' {id `Ptr ()'} -> `Int'#} {#fun csoundWaitBarrier as waitBarrier' {id `Ptr ()'} -> `Int'#} {#fun unsafe csoundSleep as sleep' {`Int'} -> `()'#} -- *Functions to manipulate time\/locale initTimerStruct' :: IO (RtClockPtr) initTimerStruct' = do ptr <- malloc {#call unsafe csoundInitTimerStruct #} ptr return ptr {#fun unsafe csoundGetRealTime as getRealTime' { id `RtClockPtr'} -> `Double'#} {#fun unsafe csoundGetCPUTime as getCPUTime' {id `RtClockPtr'} -> `Double'#} {#fun unsafe csoundGetRandomSeedFromTime as getRandomSeedFromTime' { } -> `UInt32T' cIntConv #} {#fun unsafe csoundSetLanguage as setLanguage' { cIntFromEnum `CsLanguage' } -> `()'#} {#fun unsafe csoundLocalizeString as localizeString' {`String'} -> `String'#} -- *Csound global variable manipulations {#fun unsafe csoundCreateGlobalVariable as createGlobalVariable' { id `CsoundPtr', `String', `Int' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundQueryGlobalVariable as queryGlobalVariable' { 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 queryGlobalVariableNoCheck' { id `CsoundPtr', `String' } -> `Ptr ()' id#} {#fun unsafe csoundDestroyGlobalVariable as destroyGlobalVariable' { id `CsoundPtr', `String' } -> `CsoundStatus' cIntToEnum#} {#fun pure unsafe csoundGetSizeOfMYFLT as getSizeOfMYFLT {} -> `Int'#} -- *Csound utility functions {#fun csoundRunUtility as runUtility' { id `CsoundPtr', `String', `Int', withStringList* `[String]' } -> `Bool' cIntToBoolSwitch#} {#fun unsafe csoundListUtilities as unsafeListUtilities { id `CsoundPtr' } -> `(Ptr CString, [String])' peekStringArrayPtr*#} deleteUtilityList' :: CsoundPtr -> Ptr (Ptr CChar) -> IO () deleteUtilityList' = {#call unsafe csoundDeleteUtilityList #} {#fun unsafe csoundGetUtilityDescription as getUtilityDescription' { 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 {#fun unsafe csoundGetChannelPtr as getChannelPtr' { id `CsoundPtr', alloca- `Ptr CCsndFlt' peekCsndOutAry*, `String', csoundChannelDirectionalTypeToCInt `CsoundChannelDirectionalType' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundListChannels as listChannels' { id `CsoundPtr', alloca- `CsoundChannelListEntryPtr' peek* } -> `CsoundListChannelStatus' toChannelListStatus#} deleteChannelList' :: CsoundPtr -> CsoundChannelListEntryPtr -> IO () deleteChannelList' = {#call unsafe csoundDeleteChannelList #} {#fun unsafe csoundSetControlChannelParams as setControlChannelParams' { id `CsoundPtr', `String', cIntFromEnum `CsoundControlChannelType', cFloatConv `CsndFlt', cFloatConv `CsndFlt', cFloatConv `CsndFlt' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundGetControlChannelParams as getControlChannelParams' { id `CsoundPtr', `String', alloca- `CsndFlt' peekCsndFlt*, alloca- `CsndFlt' peekCsndFlt*, alloca- `CsndFlt' peekCsndFlt* } -> `Int'#} setChannelIOCallback' :: CsoundPtr -> CsoundChannelIOCallbackT -> IO () setChannelIOCallback' = {#call csoundSetChannelIOCallback #} -- **functions for the 'ichannel' family of opcodes {#fun unsafe csoundChanIKSet as chanIKSet' { id `CsoundPtr', cFloatConv `CsndFlt', `Int' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundChanOKGet as chanOKGet' { id `CsoundPtr', alloca- `CsndFlt' peekCsndFlt*, `Int' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundChanIASet as chanIASet' { id `CsoundPtr', withCsndFltArray* `[CsndFlt]', `Int' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundChanOAGet as chanOAGet' { id `CsoundPtr', alloca- `Ptr CCsndFlt' id, `Int' } -> `CsoundStatus' cIntToEnum#} -- **Functions for PvsIn and PvsOut {#fun unsafe csoundPvsinSet as csoundPvsinSet' { id `CsoundPtr', withObject* `PvsDatExt', `Int' } -> `CsoundStatus' cIntToEnum#} {#fun unsafe csoundPvsoutGet as csoundPvsoutGet' { 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 unsafe csoundRand31 as rand31' { `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) setCallback' :: CsoundPtr -- ^Pointer to this csound instance. -> CsoundCallbackFunction -- ^Callback function -> Ptr () -- ^Pointer to "userdata" -> CsoundCallbackFunctionTypeMask -> IO CsoundSetCallbackStatus setCallback' csPtr fnPtr dataPtr typeMask = do fmap cIntToSetCallbackStatus $ {#call csoundSetCallback as csoundSetCallback_#} csPtr fnPtr dataPtr $ cIntConv typeMask removeCallback' :: CsoundPtr -> CsoundCallbackFunction -> IO () removeCallback' = {#call csoundRemoveCallback #} -- *Csound messaging functions enableMessageBuffer' :: CsoundPtr -> Int -> IO () enableMessageBuffer' csPtr toStdOut = {#call csoundEnableMessageBuffer #} csPtr $ cIntConv toStdOut {#fun csoundGetFirstMessage as getFirstMessage' { id `CsoundPtr'} -> `String'#} getFirstMessageAttr' :: CsoundPtr -> IO Int getFirstMessageAttr' csPtr = liftM cIntConv $ {#call csoundGetFirstMessageAttr #} csPtr popFirstMessage' :: CsoundPtr -> IO () popFirstMessage' = {#call csoundPopFirstMessage #} getMessageCnt' :: CsoundPtr -> IO Int getMessageCnt' csPtr = fmap cIntConv $ {#call unsafe csoundGetMessageCnt #} csPtr destroyMessageBuffer' :: CsoundPtr -> IO () destroyMessageBuffer' csPtr = {#call 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 ()) setFileOpenCallback' :: CsoundPtr -> CsoundFileOpenCallback -> IO () setFileOpenCallback' csPtr funPtr = {#call unsafe csoundSetFileOpenCallback #} csPtr funPtr #endif