diff --git a/README b/README --- a/README +++ b/README @@ -2,17 +2,21 @@ Enable control of Csound from the Haskell language. -Requirements: a haskell compiler (currently tested with GHC 6.6+), a working Csound installation, and a version of libsndfile compatible with csound. +Requirements: a haskell compiler (currently tested with GHC 6.10.x) and a working Csound installation (Csound >= 5.08 && <= 6.0). Building: In the simplest case, this program can be built in the standard cabal manner, as below: - > runhaskell Setup.lhs configure - > runhaskell Setup.lhs build - > runhaskell Setup.lhs install + > cabal configure -O2 + > cabal build + > cabal install The default is to build against 64-bit csound. The flag useDouble controls whether the library is built against 32-bit or 64-bit csound. Disable this flag (with -f-useDouble) to link to 32-bit csound. -Installing on Windows: Installing on Windows is tricky, and I have frequently had problems with the linker included in GHC and the csound DLL. Please contact the hCsound maintainer for further help. +Installing on Unix/Linux: if Csound is in a non-standard location, you may need to specify the location during the configure step. + > cabal configure -O2 --extra-include-dirs="/path/to/headers" --extra-lib-dirs="/path/to/libs" -Installing on Mac: the default cpp on Leopard seems buggy. If c2hs has lexer errors during build, build with these options: - --cpp=gcc --cppopts=-E --cppopts=-xc-header +Installing on Windows: hCsound has been successfully built on Windows, but I have frequently had problems with the linker included in GHC and the csound DLL. Your best bet is to use MinGW. Please contact the hCsound maintainer for further assistance. + +Installing on Mac: if Csound was installed using the mac installer, hCsound will link to the installed frameworks. If you have self-compiled csound and installed to a non-standard location (i.e. other than /Libraries/Frameworks/CsoundLib.framework and /Libraries/Frameworks/CsoundLib64.framework), use the flag -f-useFramework to disable linking to the frameworks. In this case you will need to specify the header and library paths using --extra-include-dirs and --extra-lib-dirs if they aren't in the default locations. + example: + > cabal configure -O2 -f-useFramework --extra-include-dirs="/path/to/headers" --extra-lib-dirs="/path/to/libs" diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -2,7 +2,7 @@ 1. On darwin/Leopard, the standard cpp doesn't work. Using the following command in the configure stage does: -runhaskell Setup.lhs configure --c2hs-options=--cpp=gcc --c2hs-options=--cppopts=-E --c2hs-options=--cppopts='-xc-header' +runhaskell Setup.lhs configure --c2hs-options=--cppopts=-U__BLOCKS__ try to make this automatic... diff --git a/examples/test2.hs b/examples/test2.hs --- a/examples/test2.hs +++ b/examples/test2.hs @@ -22,6 +22,3 @@ csoundPerformKsmpsIO ptr (\x _ -> return $ replicate x 1) (\_ _ _ -> return () ) csoundDestroy ptr -reportResult :: Either String a -> IO () -reportResult (Right _) = putStrLn ("Csound Ran! ") -reportResult (Left e) = putStrLn ("csound didn't run... " ++ (show e)) diff --git a/examples/test3.hs b/examples/test3.hs --- a/examples/test3.hs +++ b/examples/test3.hs @@ -15,6 +15,7 @@ liftIO $ csoundSetHostImplementedAudioIO ptr 1 512 csoundCompile ptr args csoundPerformBufferIO ptr (\x y -> return $ replicate x 1) (\_ _ _ -> return ()) + csoundDestroy ptr outFn l i b = putStrLn ("Buffer Length: " ++ (show l) ++ "Position: " ++ (show i)) diff --git a/hCsound.cabal b/hCsound.cabal --- a/hCsound.cabal +++ b/hCsound.cabal @@ -1,5 +1,5 @@ Name: hCsound -Version: 0.2.3 +Version: 0.3.0 Cabal-Version: >= 1.2 Description: Haskell interface to Csound API. License: LGPL @@ -26,13 +26,15 @@ Library Hs-Source-Dirs: src - src/Sound - src/Sound/Csound - build-depends: base, haskell98, mtl + build-depends: base >=3 && < 5 + ,monads-tf >= 0.1 && < 0.2 + ,transformers >= 0.2 && < 0.3 + ,vector >= 0.6 && < 0.8 build-tools: c2hs - other-modules: C2HS exposed-modules: Sound.Csound + Sound.Csound.Foreign Sound.Csound.Interface + Sound.Csound.Vector includes: csound.h extra-libraries: sndfile diff --git a/src/Sound/Csound.hs b/src/Sound/Csound.hs --- a/src/Sound/Csound.hs +++ b/src/Sound/Csound.hs @@ -8,148 +8,102 @@ -- C++ class files, such as CSoundFile.hpp, are not yet wrapped. -- Also support for cscore is currently very limited. -module Sound.Csound - ( - CsoundMonad, --exported from Interface - csoundCreate, - csoundCompile, - csoundPerform, - CsoundPerformStatus, - csoundPreCompile, - csoundSetHostImplementedAudioIO, +module Sound.Csound ( + module Sound.Csound.Interface, + -- defined in this module + performKsmpsIO, + performBufferIO, + withChannelList, + runSimple +) --- defined in this module - csoundPerformKsmpsIO, - csoundPerformBufferIO, - withOpcodeList, - withUtilityList, - listUtilityNames, - withChannelList - ) where -import Sound.Csound.Interface -import Foreign.Marshal.Array (peekArray, pokeArray) -import Control.Monad.Error (liftIO, throwError) -import Control.Exception (bracket) +import Sound.Csound.Foreign +import Sound.Csound.Interface +import Sound.Csound.Vector +import Foreign.Marshal.Array (peekArray, pokeArray) +import Control.Exception (bracket) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Error +import Control.Monad.State + +-- |Basic run with csound-implemented I/O +runSimple :: String -> IO (Maybe CsoundError) +runSimple args = fmap rf $ runCsound csnd + where + csnd = compile args >> perform >> destroy + rf = either Just (const Nothing) + -- Functions to perform a score with input and output from the host. --- |Perform an entire score using csoundPerformKsmps, with handling of +-- |Perform an entire score using performKsmps, with handling of -- input and output buffers spin and spout. Note that --- csoundSetHostImplementedIO must be called before csoundCompile. -csoundPerformKsmpsIO :: - CsoundPtr -- ^Pointer to csound instance - -> (Int -> Int -> IO [CsndFlt]) -- ^Function that takes buffer size - -- and starting position (in samples) - -- and returns a list of length - -- buffersize of input to use. - -> (Int -> Int -> [CsndFlt] -> IO ()) -- ^Function that takes - -- buffer size, starting - -- position (in samples), - -- and list of CsndFlt - -- and performs an IO action - -- with the [CsndFlt] - -> CsoundMonad () -csoundPerformKsmpsIO csPtr inBuf outBuf = csoundPerformKsmpsIO' 0 - where - bufSize = csoundGetKsmps csPtr - ifn = inBuf bufSize - ofn = outBuf bufSize - peekFn = peekArray bufSize - csoundPerformKsmpsIO' :: Int -> CsoundMonad () - csoundPerformKsmpsIO' iposAcc = do - liftIO $ csoundGetSpin' csPtr >>= \iptr -> - ifn iposAcc >>= pokeArray iptr - res <- csoundPerformKsmps csPtr - liftIO $ csoundGetSpout' csPtr >>= peekFn >>= ofn iposAcc - case res of - PerformStopped -> let newPosAcc = iposAcc + bufSize in - csoundPerformKsmpsIO' newPosAcc - PerformFinished -> return () - _ -> throwError $ show res +-- setHostImplementedIO must be called before compile. +performKsmpsIO :: + (Int -> Int -> IO CsVector) -- ^Function that takes buffer size + -- and starting position (in samples) + -- and returns a list of length + -- buffersize of input to use. + -> (Int -> Int -> CsVector -> IO ()) -- ^Function that takes + -- buffer size, starting + -- position (in samples), + -- and list of CsndFlt + -- and performs an IO action + -- with the [CsndFlt] + -> Csound () +performKsmpsIO inBuf outBuf = do + bufSize <- getKsmps + let ifn = inBuf bufSize + let ofn = outBuf bufSize + let performKsmpsIO' :: Int -> Csound () + performKsmpsIO' iposAcc = do + liftIO (ifn iposAcc) >>= unsafeVec2Spin + res <- performKsmps + readSpout >>= liftIO . ofn iposAcc + case res of + PerformStopped -> let newPosAcc = iposAcc + bufSize in + performKsmpsIO' newPosAcc + PerformFinished -> return () + PerformError stat -> throwError $ CsStatus stat + performKsmpsIO' 0 --- |Perform an entire score using csoundPerformBuffer, with handling of +-- |Perform an entire score using performBuffer, with handling of -- input and output buffers. -csoundPerformBufferIO :: - CsoundPtr -- ^Pointer to Csound struct - -> (Int -> Int -> IO [CsndFlt]) -- ^Function that takes buffer size and - -- starting position (in samples) and - -- returns a list of length buffersize - -- of input to use. - -> (Int -> Int -> [CsndFlt] -> IO ()) -- ^Function that takes buffer - -- size, starting position - -- (in samples), and list of CsndFlt - -- and performs an IO action - -- with the [CsndFlt] - -> CsoundMonad () -csoundPerformBufferIO csp inBuf outBuf = csoundPerformBufferIO' 0 - where - inBufSize = csoundGetInputBufferSize csp - ifn = inBuf inBufSize - outBufSize = csoundGetOutputBufferSize csp - ofn = outBuf outBufSize - peekFn = peekArray $ csoundGetInputBufferSize csp - csoundPerformBufferIO' :: Int -> CsoundMonad () - csoundPerformBufferIO' iposAcc = do - liftIO $ csoundGetInputBuffer' csp >>= - \iptr -> ifn iposAcc >>= pokeArray iptr - res <- csoundPerformBuffer csp - liftIO $ csoundGetOutputBuffer' csp >>= peekFn >>= ofn iposAcc - case res of - PerformStopped -> let newPosAcc = iposAcc+inBufSize in - csoundPerformBufferIO' newPosAcc - PerformFinished -> return () - _ -> throwError $ show res --Again, this should never happen - --- |Perform an IO action with the current csound opcode list, --- properly disposing of the list after completing the action. -withOpcodeList :: CsoundPtr -> ([OpcodeListEntry] -> IO b) -> CsoundMonad b -withOpcodeList csPtr func = do - openRes <- csoundNewOpcodeList csPtr - liftIO $ bracket (return openRes) disposeFunc procFunc - where - disposeFunc (ptr, _) = csoundDisposeOpcodeList csPtr ptr - procFunc (_, list) = func list - --- |Perform an action within the IO monad, using the list of named utilities. -withUtilityList :: CsoundPtr -> ([String] -> IO b) -> CsoundMonad b -withUtilityList csPtr func = do - openRes <- csoundListUtilities csPtr - case openRes of - (_, []) -> throwError "No utilities found." - _ -> liftIO $ bracket (return openRes) disposeFunc procFunc - where - disposeFunc (ptr, _) = csoundDeleteUtilityList csPtr ptr - procFunc (_, list) = func list - --- |Get a list of all the registered csound utilities. This should be used instead of csoundListUtilities. --- because this function calls csoundDeleteUtilityList after use. -listUtilityNames :: CsoundPtr -> CsoundMonad [String] -listUtilityNames csPtr = withUtilityList csPtr return +performBufferIO :: + (Int -> Int -> IO CsVector) -- ^Function that takes buffer size and + -- starting position (in samples) and + -- returns a list of length buffersize + -- of input to use. + -> (Int -> Int -> CsVector -> IO ()) -- ^Function that takes buffer + -- size, starting position + -- (in samples), and list of CsndFlt + -- and performs an IO action + -- with the [CsndFlt] + -> Csound () +performBufferIO inBuf outBuf = do + inBufSize <- getInputBufferSize + outBufSize <- getOutputBufferSize + let ifn = inBuf inBufSize + let ofn = outBuf outBufSize + let performBufferIO' :: Int -> Csound () + performBufferIO' iposAcc = do + ibufSz <- getInputBufferSize + liftIO (ifn iposAcc) >>= vec2Ibuf + res <- performBuffer + readObuf >>= liftIO . ofn iposAcc + case res of + PerformStopped -> performBufferIO' $! iposAcc+inBufSize + PerformFinished -> return () + PerformError stat -> throwError $ CsStatus stat :: Csound () + performBufferIO' 0 -- |Perform an action within the IO monad, using the list of channels. -withChannelList :: CsoundPtr -> ([CsoundChannelListEntry] -> IO a) -> CsoundMonad a -withChannelList csPtr func = do - openRes <- csoundListChannels csPtr - case openRes of - (_, []) -> throwError "No open channels" - _ -> liftIO $ bracket (return openRes) disposeFunc procFunc - where - disposeFunc (ptr, _) = csoundDeleteChannelList csPtr ptr - procFunc (_, list) = func list +withChannelList :: ([CsoundChannelListEntry] -> IO a) -> Csound a +withChannelList func = do + openRes <- listChannels + x <- liftIO . func . snd $ openRes + deleteChannelList . fst $ openRes + return x --- |Perform a simple run of csound, with no special handling. -{- -runCsoundSimple :: String -> CsoundMonad CsoundPerformStatus -runCsoundSimple argList = do - perfStatus <- liftIO $ bracket (csoundCreate nullPtr) csoundDestroy perform - where - perform csPtr = do - res <- csoundCompile csPtr argv argc - case res of - CsoundSuccess -> csoundPerform csPtr - otherwise -> return $ PerformError res - argc = "csound" : words argList - argv = length argc --} diff --git a/src/Sound/Csound/C2HS.hs b/src/Sound/Csound/C2HS.hs deleted file mode 100644 --- a/src/Sound/Csound/C2HS.hs +++ /dev/null @@ -1,220 +0,0 @@ --- C->Haskell Compiler: Marshalling library --- --- Copyright (c) [1999...2005] Manuel M T Chakravarty --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- 1. Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- 2. Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- 3. The name of the author may not be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR --- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES --- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN --- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ---- Description --------------------------------------------------------------- --- --- Language: Haskell 98 --- --- This module provides the marshaling routines for Haskell files produced by --- C->Haskell for binding to C library interfaces. It exports all of the --- low-level FFI (language-independent plus the C-specific parts) together --- with the C->HS-specific higher-level marshalling routines. --- - -module C2HS ( - - -- * Re-export the language-independent component of the FFI - module Foreign, - - -- * Re-export the C language component of the FFI - module CForeign, - - -- * Composite marshalling functions - withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, - peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, - - -- * Conditional results using 'Maybe' - nothingIf, nothingIfNull, - - -- * Bit masks - combineBitMasks, containsBitMask, extractBitMasks, - - -- * Conversion between C and Haskell types - cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum -) where - - -import Foreign - hiding (Word) - -- Should also hide the Foreign.Marshal.Pool exports in - -- compilers that export them -import CForeign - -import Monad (when, liftM) - - --- Composite marshalling functions --- ------------------------------- - --- Strings with explicit length --- -withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) -peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) - --- Marshalling of numerals --- - -withIntConv :: (Storable b, Integral a, Integral b) - => a -> (Ptr b -> IO c) -> IO c -withIntConv = with . cIntConv - -withFloatConv :: (Storable b, RealFloat a, RealFloat b) - => a -> (Ptr b -> IO c) -> IO c -withFloatConv = with . cFloatConv - -peekIntConv :: (Storable a, Integral a, Integral b) - => Ptr a -> IO b -peekIntConv = liftM cIntConv . peek - -peekFloatConv :: (Storable a, RealFloat a, RealFloat b) - => Ptr a -> IO b -peekFloatConv = liftM cFloatConv . peek - --- Passing Booleans by reference --- - -withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b -withBool = with . fromBool - -peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool -peekBool = liftM toBool . peek - - --- Passing enums by reference --- - -withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c -withEnum = with . cFromEnum - -peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a -peekEnum = liftM cToEnum . peek - - --- Storing of 'Maybe' values --- ------------------------- - -instance Storable a => Storable (Maybe a) where - sizeOf _ = sizeOf (undefined :: Ptr ()) - alignment _ = alignment (undefined :: Ptr ()) - - peek p = do - ptr <- peek (castPtr p) - if ptr == nullPtr - then return Nothing - else liftM Just $ peek ptr - - poke p v = do - ptr <- case v of - Nothing -> return nullPtr - Just v' -> new v' - poke (castPtr p) ptr - - --- Conditional results using 'Maybe' --- --------------------------------- - --- Wrap the result into a 'Maybe' type. --- --- * the predicate determines when the result is considered to be non-existing, --- ie, it is represented by `Nothing' --- --- * the second argument allows to map a result wrapped into `Just' to some --- other domain --- -nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b -nothingIf p f x = if p x then Nothing else Just $ f x - --- |Instance for special casing null pointers. --- -nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b -nothingIfNull = nothingIf (== nullPtr) - - --- Support for bit masks --- --------------------- - --- Given a list of enumeration values that represent bit masks, combine these --- masks using bitwise disjunction. --- -combineBitMasks :: (Enum a, Bits b) => [a] -> b -combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) - --- Tests whether the given bit mask is contained in the given bit pattern --- (i.e., all bits set in the mask are also set in the pattern). --- -containsBitMask :: (Bits a, Enum b) => a -> b -> Bool -bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm - in - bm' .&. bits == bm' - --- |Given a bit pattern, yield all bit masks that it contains. --- --- * This does *not* attempt to compute a minimal set of bit masks that when --- combined yield the bit pattern, instead all contained bit masks are --- produced. --- -extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] -extractBitMasks bits = - [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] - - --- Conversion routines --- ------------------- - --- |Integral conversion --- -cIntConv :: (Integral a, Integral b) => a -> b -cIntConv = fromIntegral - --- |Floating conversion --- -cFloatConv :: (RealFloat a, RealFloat b) => a -> b -cFloatConv = realToFrac --- As this conversion by default goes via `Rational', it can be very slow... -{-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; - "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x - #-} - --- |Obtain C value from Haskell 'Bool'. --- -cFromBool :: Num a => Bool -> a -cFromBool = fromBool - --- |Obtain Haskell 'Bool' from C value. --- -cToBool :: Num a => a -> Bool -cToBool = toBool - --- |Convert a C enumeration to Haskell. --- -cToEnum :: (Integral i, Enum e) => i -> e -cToEnum = toEnum . cIntConv - --- |Convert a Haskell enumeration to C. --- -cFromEnum :: (Enum e, Integral i) => e -> i -cFromEnum = cIntConv . fromEnum diff --git a/src/Sound/Csound/Foreign.chs b/src/Sound/Csound/Foreign.chs new file mode 100644 --- /dev/null +++ b/src/Sound/Csound/Foreign.chs @@ -0,0 +1,1385 @@ +{-# 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 diff --git a/src/Sound/Csound/Interface.chs b/src/Sound/Csound/Interface.chs deleted file mode 100644 --- a/src/Sound/Csound/Interface.chs +++ /dev/null @@ -1,1605 +0,0 @@ -{-# 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 - --- **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 = 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'#} --} - -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 . liftM (map cFloatConv) $ - peekArray (val+1) ptr - Nothing -> throwError $ - "Table " ++ show tableNum ++ " not found." - -{#fun unsafe csoundGetTable as csoundGetTable' - { - 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 - -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 CCsndFlt) -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 CCsndFlt' 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 diff --git a/src/Sound/Csound/Interface.hs b/src/Sound/Csound/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Csound/Interface.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE 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.Interface ( + -- * Types + CsndFlt + ,UInt32T + ,CsoundError (..) + ,Csound (..) + ,CsoundInit + ,CsoundPerformStatus (..) + ,CsoundSetCallbackStatus (..) + ,CsoundCallbackFunctionType + ,CsoundCallbackFunctionTypeMask + ,OpcodeListEntry (..) + + -- * Csound Functions + -- ** Engine + ,runCsound + ,destroy + ,preCompile + ,initializeCscore + ,queryInterface + ,getHostData + ,setHostData + ,getEnv + ,setGlobalEnv + + -- ** Performance functions + ,compile + ,perform + ,performKsmps + ,performKsmpsAbsolute + ,performBuffer + ,stop + ,cleanup + ,reset + ,setHostImplementedAudioIO + ,unsafePerformKsmps + + -- *** buffer access + ,getInputBufferSize + ,getOutputBufferSize + ,getInputBuffer + ,getOutputBuffer + ,getSpin + ,getSpout + + -- ** Csound attributes + ,getSr + ,getKr + ,getKsmps + ,getNchnls + ,get0dBFS + ,getStrVarMaxLen + ,getSampleFormat + ,getSampleSize + ,getOutputFileName + ,getDebug + ,setDebug + + -- ** Score functions + ,getScoreTime + ,isScorePending + ,setScorePending + ,getScoreOffsetSeconds + ,setScoreOffsetSeconds + ,rewindScore + ,setCscoreCallback + ,scoreSort + ,scoreExtract + ,scoreEvent + + -- ** Messages + ,getMessageLevel + ,setMessageLevel + ,inputMessage + ,keyPress + + -- *** Callbacks + ,setInputValueCallback + ,setOutputValueCallback + + -- *** operations + ,enableMessageBuffer + ,getFirstMessage + ,getFirstMessageAttr + ,popFirstMessage + ,getMessageCnt + ,destroyMessageBuffer + + -- ** MIDI + ,setExternalMidiInOpenCallback + ,setExternalMidiReadCallback + ,setExternalMidiInCloseCallback + ,setExternalMidiOutOpenCallback + ,setExternalMidiWriteCallback + ,setExternalMidiErrorStringCallback + + -- ** Graphing + ,setIsGraphable + ,setMakeGraphCallback + ,setDrawGraphCallback + ,setKillGraphCallback + ,setMakeXYinCallback + ,setReadXYinCallback + ,setKillXYinCallback + ,setExitGraphCallback + + -- ** Opcode manipulation + ,newOpcodeList + ,disposeOpcodeList + ,appendOpcode + + -- ** Library + ,openLibrary + ,closeLibrary + ,getLibrarySymbol + + -- ** Real-time Play/Record + ,setYieldCallback + ,setPlayopenCallback + ,setRtplayCallback + ,setRecopenCallback + ,setRtrecordCallback + ,setRtcloseCallback + ,getRtRecordUserData + ,getRtPlayUserData + ,registerSenseEventCallback + + -- ** FTables + ,tableLength + ,tableGet + ,tableSet + ,getTable + ,withTable + + -- ** Threading + ,createThread + ,getCurrentThreadId + ,joinThread + ,runCommand + ,createThreadLock + ,waitThreadLock + ,waitThreadLockNoTimeout + ,notifyThreadLock + ,destroyThreadLock + ,createMutex + ,lockMutex + ,lockMutexNoWait + ,unlockMutex + ,destroyMutex + ,createBarrier + ,destroyBarrier + ,waitBarrier + ,sleep + + -- ** Timing + ,initTimerStruct + ,getRealTime + ,getCPUTime + ,getRandomSeedFromTime + + -- ** Locality + ,setLanguage + ,localizeString + + -- ** Globals + ,createGlobalVariable + ,queryGlobalVariable + ,queryGlobalVariableNoCheck + ,destroyGlobalVariable + + -- ** Utilities + ,runUtility + ,listUtilities + ,getUtilityDescription + + -- ** Communications + -- *** 'chan' opcodes + ,getChannelPtr + ,listChannels + ,deleteChannelList + ,setControlChannelParams + ,getControlChannelParams + ,setChannelIOCallback + + -- *** 'ichannel' opcodes + ,chanIKSet + ,chanOKGet + ,chanIASet + ,chanOAGet + + -- *** 'pvs' opcodes + ,pvsinSet + ,pvsoutGet + + -- ** Callbacks + ,setCallback + ,removeCallback + ,setFileOpenCallback + + -- ** Randomization + ,rand31 +) + +where + +import Sound.Csound.Foreign +import Control.Applicative +import Control.Monad (liftM) +import Control.Monad.IO.Class +import Control.Monad.Error +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 + +io0cm :: (CsoundPtr -> IO a) -> Csound a +io0cm f = ask >>= liftIO . f + +io1cm :: (CsoundPtr -> a -> IO b) -> a -> Csound b +io1cm f a = ask >>= liftIO . flip f a + +io2cm :: (CsoundPtr -> a -> b -> IO c) -> a -> b -> Csound c +io2cm f a b = ask >>= \csptr -> liftIO (f csptr a b) + +io3cm :: (CsoundPtr -> a -> b -> c -> IO d) -> a -> b -> c -> Csound d +io3cm f a b c = ask >>= \csptr -> liftIO (f csptr a b c) + +runCsound :: Csound a -> IO (Either CsoundError a) +runCsound csd = do + p <- unsafeCsoundCreate nullPtr + res <- runErrorT $ runReaderT (unStack csd) p + -- need to destroy the pointer even if Csound threw an error + -- not using bracket because it's probably not safe to destroy the + -- pointer in case of an IO exception. + destroy' p + return res + + +destroy :: Csound () +destroy = io0cm destroy' + +preCompile :: Csound () +preCompile = ask >>= csoundStatusWrapper . unsafeCsoundPreCompile + +initializeCscore :: FilePtr -> FilePtr -> Csound () +initializeCscore iScore oScore = do + csPtr <- ask + csoundStatusWrapper $ unsafeCsoundInitializeCscore csPtr iScore oScore + +queryInterface :: String -> Csound (CsoundStatus, Ptr (), Int) +queryInterface str = do + res <- liftIO $ csoundQueryInterface' str + case res of + (CsoundSuccess, _, _) -> return res + (errCode, _, _) -> throwError $ CsStatus errCode + +getHostData :: Csound (Ptr ()) +getHostData = io0cm getHostData' + +setHostData :: Ptr () -> Csound () +setHostData = io1cm setHostData' + +getEnv :: String -> Csound String +getEnv str = ask >>= liftIO . flip getEnv' str + +setGlobalEnv :: String -> String -> Csound () +setGlobalEnv name value = csoundStatusWrapper $ setGlobalEnv' name value + +-- *Performance functions +compile :: String -> Csound () +compile argList = ask >>= \csPtr -> csoundStatusWrapper $ + compile' csPtr argv argc + where + argc = "csound" : words argList + argv = length argc + +perform :: Csound CsoundPerformStatus +perform = ask >>= csPerformStatusWrapper . perform' + +performKsmps :: Csound CsoundPerformStatus +performKsmps = ask >>= csPerformStatusWrapper . performKsmps' + +-- | Perform a Ksmps buffer. The C function is called with the "unsafe" +-- modifier, which makes callbacks to Haskell unsafe. +unsafePerformKsmps :: Csound CsoundPerformStatus +unsafePerformKsmps = ask >>= csPerformStatusWrapper . unsafePerformKsmps' + +performKsmpsAbsolute :: Csound CsoundPerformStatus +performKsmpsAbsolute = ask >>= csPerformStatusWrapper . + performKsmpsAbsolute' + +performBuffer :: Csound CsoundPerformStatus +performBuffer = ask >>= csPerformStatusWrapper . performBuffer' + +stop :: Csound () +stop = io0cm stop' + +cleanup :: Csound Int +cleanup = io0cm cleanup' + +reset :: Csound () +reset = io0cm reset' + +-- *Csound Attributes +getSr :: Csound CsndFlt +getSr = io0cm getSr' + +getKr :: Csound CsndFlt +getKr = io0cm getKr' + +getKsmps :: Csound Int +getKsmps = io0cm getKsmps' + +getNchnls :: Csound Int +getNchnls = io0cm getNchnls' + +get0dBFS :: Csound CsndFlt +get0dBFS = io0cm get0dBFS' + +getStrVarMaxLen :: Csound Int +getStrVarMaxLen = io0cm getStrVarMaxLen' + +getSampleFormat :: Csound Int +getSampleFormat = io0cm getSampleFormat' + +getSampleSize :: Csound Int +getSampleSize = io0cm getSampleSize' + +getInputBufferSize :: Csound Int +getInputBufferSize = io0cm getInputBufferSize' + +getOutputBufferSize :: Csound Int +getOutputBufferSize = io0cm getOutputBufferSize' + +getInputBuffer :: Csound (Ptr CsndFlt) +getInputBuffer = io0cm getInputBuffer' + +getOutputBuffer :: Csound (Ptr CsndFlt) +getOutputBuffer = io0cm getOutputBuffer' + +getSpin :: Csound (Ptr CsndFlt) +getSpin = io0cm getSpin' + +getSpout :: Csound (Ptr CsndFlt) +getSpout = io0cm getSpout' + +getOutputFileName :: Csound String +getOutputFileName = io0cm getOutputFileName' + +setHostImplementedAudioIO :: Int -> Int -> Csound () +setHostImplementedAudioIO = io2cm setHostImplementedAudioIO' + +-- ----------------------------------------------- +-- Score functions + +getScoreTime :: Csound CsndFlt +getScoreTime = io0cm getScoreTime' + +isScorePending :: Csound Int +isScorePending = io0cm isScorePending' + +setScorePending :: Int -> Csound () +setScorePending = io1cm setScorePending' + +getScoreOffsetSeconds :: Csound CsndFlt +getScoreOffsetSeconds = io0cm getScoreOffsetSeconds' + +setScoreOffsetSeconds :: CsndFlt -> Csound () +setScoreOffsetSeconds = io1cm setScoreOffsetSeconds' + +rewindScore :: Csound () +rewindScore = io0cm rewindScore' + +setCscoreCallback :: FunPtr (CsoundPtr -> IO ()) -> Csound () +setCscoreCallback = io1cm setCscoreCallback' + +scoreSort :: FilePtr -> FilePtr -> Csound () +scoreSort inFile outFile = do + csPtr <- ask + csoundStatusWrapper $ scoreSort' csPtr inFile outFile + +scoreExtract :: FilePtr -> FilePtr -> FilePtr -> Csound () +scoreExtract inFile outFile extractFile = do + csPtr <- ask + csoundStatusWrapper $ scoreExtract' csPtr inFile outFile extractFile + +-- ------------------------------------- +-- Messages and Text + +getMessageLevel :: Csound Int +getMessageLevel = io0cm getMessageLevel' + +setMessageLevel :: Int -> Csound () +setMessageLevel = io1cm setMessageLevel' + +inputMessage :: String -> Csound () +inputMessage = io1cm inputMessage' + +keyPress :: Char -> Csound () +keyPress = io1cm keyPress' + +-- ------------------------------------- +-- Callback functions +setInputValueCallback :: InputValueCallback -> Csound () +setInputValueCallback = io1cm setInputValueCallback' + +setOutputValueCallback :: OutputValueCallback -> Csound () +setOutputValueCallback = io1cm setOutputValueCallback' + +scoreEvent :: Char -> [CsndFlt] -> Int -> Csound Int +scoreEvent = io3cm scoreEvent' + +-- ------------------------------------- +-- MIDI + +setExternalMidiInOpenCallback :: ExternalMidiOpenCallback -> Csound () +setExternalMidiInOpenCallback = io1cm setExternalMidiInOpenCallback' + +setExternalMidiReadCallback :: ExternalMidiReadCallback -> Csound () +setExternalMidiReadCallback = io1cm setExternalMidiReadCallback' + +setExternalMidiInCloseCallback :: ExternalMidiCloseCallback -> Csound () +setExternalMidiInCloseCallback = io1cm setExternalMidiInCloseCallback' + +setExternalMidiOutOpenCallback :: ExternalMidiOpenCallback -> Csound () +setExternalMidiOutOpenCallback = io1cm setExternalMidiOutOpenCallback' + +setExternalMidiWriteCallback :: ExternalMidiWriteCallback -> Csound () +setExternalMidiWriteCallback = io1cm setExternalMidiWriteCallback' + +setExternalMidiErrorCallback :: ExternalMidiErrorStringCallback -> Csound () +setExternalMidiErrorCallback = io1cm setExternalMidiErrorStringCallback' + +setExternalMidiErrorStringCallback :: + ExternalMidiErrorStringCallback + -> Csound () +setExternalMidiErrorStringCallback = io1cm setExternalMidiErrorStringCallback' + +-- ------------------------------------- +-- Graph/Table functions + +setIsGraphable :: Int -> Csound Int +setIsGraphable = io1cm setIsGraphable' + +setMakeGraphCallback :: MakeGraphCallback -> Csound () +setMakeGraphCallback = io1cm setMakeGraphCallback' + +setDrawGraphCallback :: DrawGraphCallback -> Csound () +setDrawGraphCallback = io1cm setDrawGraphCallback' + +setKillGraphCallback :: KillGraphCallback -> Csound () +setKillGraphCallback = io1cm setKillGraphCallback' + +setMakeXYinCallback :: MakeXYinCallback -> Csound () +setMakeXYinCallback = io1cm setMakeXYinCallback' + +setReadXYinCallback :: ReadXYinCallback -> Csound () +setReadXYinCallback = io1cm setReadXYinCallback' + +setKillXYinCallback :: KillXYinCallback -> Csound () +setKillXYinCallback = io1cm setKillXYinCallback' + +setExitGraphCallback :: ExitGraphCallback -> Csound () +setExitGraphCallback = io1cm setExitGraphCallback' + + +-- ------------------------------------- +-- **Csound opcode manipulation functions +newOpcodeList :: Csound [OpcodeListEntry] +newOpcodeList = do + csptr <- ask + (arrayLen, ptr) <- liftIO $ newOpcodeList' csptr + if arrayLen >= 0 + then liftIO (peekArray arrayLen ptr) <* disposeOpcodeList ptr + else throwError $ CsStatus (toEnum arrayLen) + +disposeOpcodeList :: OpcodeListEntryPtr -> Csound () +disposeOpcodeList = io1cm disposeOpcodeList' + +appendOpcode :: + String -- ^Name of opcode to append + -> Int -- ^dsblksize + -> Int -- ^thread id + -> String -- ^outypes + -> String -- ^intypes + -> OpcodeFunction -- ^iopadr + -> OpcodeFunction -- ^kopadr + -> OpcodeFunction -- ^aopadr + -> Csound () +appendOpcode opName dsblksz thread outypes intypes iopadr kopadr aopadr = do + csPtr <- ask + csoundStatusWrapper $ appendOpcode' csPtr opName dsblksz + thread outypes intypes iopadr kopadr aopadr + +-- ----------------------------------------- +-- **Csound library functions. + +openLibrary :: String -> Csound (Int, Ptr ()) +openLibrary = liftIO . openLibrary' + +closeLibrary :: Ptr () -> Csound Int +closeLibrary = liftIO . closeLibrary' + +getLibrarySymbol :: Ptr () -> String -> Csound (Ptr ()) +getLibrarySymbol ptr str = liftIO $ getLibrarySymbol' ptr str + +-- *Real-time Audio Play and Record +-- **wrappers to csound real-time audio functions. + +setYieldCallback :: YieldCallback -> Csound () +setYieldCallback = io1cm setYieldCallback' + +setPlayopenCallback :: PlayopenCallback -> Csound () +setPlayopenCallback = io1cm setPlayopenCallback' + +setRtplayCallback :: RtplayCallback -> Csound () +setRtplayCallback = io1cm setRtplayCallback' + +setRecopenCallback :: RecopenCallback -> Csound () +setRecopenCallback = io1cm setRecopenCallback' + +setRtrecordCallback :: RtrecordCallback -> Csound () +setRtrecordCallback = io1cm setRtrecordCallback' + +setRtcloseCallback :: RtcloseCallback -> Csound () +setRtcloseCallback = io1cm setRtcloseCallback' + +getRtRecordUserData :: Csound (Ptr (Ptr ())) +getRtRecordUserData = io0cm getRtRecordUserData' + +getRtPlayUserData :: Csound (Ptr (Ptr ())) +getRtPlayUserData = io0cm getRtPlayUserData' + +registerSenseEventCallback :: + FunPtr ( + CsoundPtr + -> Ptr () + -> IO () ) + -> Ptr () + -> Csound () +registerSenseEventCallback funPtr dataPtr = do + csPtr <- ask + boolWrapper "RegisterSenseEventCallback failed." $ + registerSenseEventCallback' csPtr funPtr dataPtr + +getDebug :: Csound Bool +getDebug = io0cm getDebug' + +setDebug :: Bool -> Csound () +setDebug = io1cm setDebug' + +-- *Functions to set and retrieve information from csound function tables. +tableLength :: Int -> Csound Int +tableLength tblNum = do + csPtr <- ask + tableLen <- liftIO $ tableLength' csPtr tblNum + if tableLen > 0 + then return tableLen + else throwError $ CsString "Table not found." + +tableGet :: Int -> Int -> Csound CsndFlt +tableGet = io2cm tableGet' + +tableSet :: Int -> Int -> CsndFlt -> Csound () +tableSet = io3cm tableSet' + +getTable :: Int -> Csound [CsndFlt] +getTable tableNum = do + csptr <- ask + (arrayLen, ptr) <- liftIO $ getTable' csptr tableNum + --Adding 1 to the length to account for the guard point. + case arrayLen of + Just val -> liftIO . liftM (map cFloatConv) $ peekArray (val+1) ptr + Nothing -> throwError $ CsString $ + "Table " ++ show tableNum ++ " not found." + +-- |Performs an action with a table. The type of CCsndFlt is +-- unfortunately csound-dependent. +withTable :: Int -> (Ptr CCsndFlt -> Int -> IO b) -> Csound b +withTable tableNum f = do + csptr <- ask + (arrayLen, ptr) <- liftIO $ getTable' csptr tableNum + case arrayLen of + Just val -> liftIO $ f ptr val + Nothing -> throwError . CsString $ + "Table " ++ show tableNum ++ " not found." + +-- *Csound threading +-- **Csound threading functions + +createThread :: FunPtr (Ptr () -> IO UIntPtrT) -> Ptr () -> Csound (Ptr ()) +createThread fp p = liftIO $ createThread' fp p + +getCurrentThreadId :: Csound (Ptr ()) +getCurrentThreadId = liftIO getCurrentThreadId' + +joinThread :: Ptr () -> Csound UIntPtrT +joinThread = liftIO . joinThread' + +runCommand :: [String] -> Bool -> Csound Int +runCommand args noWait = do + output <- liftIO $ runCommand' args noWait + if output < 0 + then throwError . CsString $ show output + else return output + +createThreadLock :: Csound (Ptr ()) +createThreadLock = liftIO createThreadLock' + +waitThreadLock :: Ptr () -> Int -> Csound (Bool, Ptr ()) +waitThreadLock ptr i = liftIO $ waitThreadLock' ptr i + +waitThreadLockNoTimeout :: Ptr () -> Csound () +waitThreadLockNoTimeout = liftIO . waitThreadLockNoTimeout' + +notifyThreadLock :: Ptr () -> Csound () +notifyThreadLock = liftIO . notifyThreadLock' + +destroyThreadLock :: Ptr () -> Csound () +destroyThreadLock = liftIO . destroyThreadLock' + +createMutex :: CInt -> Csound (Ptr ()) +createMutex = liftIO . createMutex' + +lockMutex :: Ptr () -> Csound () +lockMutex = liftIO . lockMutex' + +lockMutexNoWait :: Ptr () -> Csound AcquiredMutex +lockMutexNoWait = liftIO . lockMutexNoWait' + +unlockMutex :: Ptr () -> Csound () +unlockMutex = liftIO . unlockMutex' + +destroyMutex :: Ptr () -> IO () +destroyMutex = liftIO . destroyMutex' + +createBarrier :: Int -> Csound (Ptr ()) +createBarrier = liftIO . createBarrier' + +destroyBarrier :: Ptr () -> Csound Int +destroyBarrier = liftIO . destroyBarrier' + +waitBarrier :: Ptr () -> Csound Int +waitBarrier = liftIO . waitBarrier' + +sleep :: Int -> Csound () +sleep = liftIO . sleep' + +-- --------------------------------------- +-- *Time / local functions +initTimerStruct :: Csound RtClockPtr +initTimerStruct = liftIO initTimerStruct' + +getRealTime :: RtClockPtr -> Csound Double +getRealTime = liftIO . getRealTime' + +getCPUTime :: RtClockPtr -> Csound Double +getCPUTime = liftIO . getCPUTime' + +getRandomSeedFromTime :: Csound UInt32T +getRandomSeedFromTime = liftIO getRandomSeedFromTime' + +setLanguage :: CsLanguage -> Csound () +setLanguage = liftIO . setLanguage' + +localizeString :: String -> Csound String +localizeString = liftIO . localizeString' + +-- *Csound global variable manipulations +createGlobalVariable :: String -> Int -> Csound () +createGlobalVariable name sz = do + csPtr <- ask + csoundStatusWrapper $ createGlobalVariable' csPtr name sz + +queryGlobalVariable :: String -> Csound (Maybe (Ptr ())) +queryGlobalVariable = io1cm queryGlobalVariable' + +queryGlobalVariableNoCheck :: String -> Csound (Ptr ()) +queryGlobalVariableNoCheck = io1cm queryGlobalVariableNoCheck' + +destroyGlobalVariable :: String -> Csound () +destroyGlobalVariable name = do + csPtr <- ask + csoundStatusWrapper $ destroyGlobalVariable' csPtr name + + +-- *Csound utility functions +runUtility :: String -> String -> Csound () +runUtility name args = do + csPtr <- ask + boolWrapper errStr $ runUtility' csPtr name argv argc + where + errStr = "Attempt to run utility " ++ name ++ " failed." + argc = words args + argv = length argc + +listUtilities :: Csound ([String]) +listUtilities = do + csPtr <- ask + (p, u) <- liftIO $ unsafeListUtilities csPtr + liftIO $ deleteUtilityList' csPtr p + return u + +getUtilityDescription :: String -> Csound String +getUtilityDescription = io1cm getUtilityDescription' + +-- *Csound channel functions + +-- **Functions for the 'chan' family of opcodes +getChannelPtr :: String -> CsoundChannelDirectionalType -> Csound (Ptr CCsndFlt) +getChannelPtr name chantype = do + csPtr <- ask + res <- liftIO $ getChannelPtr' csPtr name chantype + case res of + (CsoundSuccess, myPtr) -> return myPtr + (err, _) -> throwError . CsString $ "Error '" ++ show err ++ + "' getting channel pointer " ++ name ++ "." + +listChannels :: Csound (CsoundChannelListEntryPtr, [CsoundChannelListEntry]) +listChannels = do + csPtr <- ask + (arrayLen, ptr) <- liftIO $ listChannels' csPtr + case arrayLen of + NumChannels 0 -> return (ptr, []) + NumChannels nC -> do + vals <- liftIO $ peekArray nC ptr + return (ptr, vals) + ChanError err -> throwError $ CsStatus err + +deleteChannelList :: CsoundChannelListEntryPtr -> Csound () +deleteChannelList = io1cm deleteChannelList' + +setControlChannelParams :: + 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 + -> Csound () +setControlChannelParams chanName chanType defVal minVal maxVal = do + csPtr <- ask + csoundStatusWrapper $ setControlChannelParams' csPtr chanName + chanType defVal minVal maxVal + +-- |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 Csound. +getControlChannelParams :: + String -- ^Name of channel to query + -> Csound (Maybe (CsoundControlChannelType, CsndFlt, CsndFlt, CsndFlt)) +getControlChannelParams chanName = do + (typ, d, mn, mx) <- io1cm getControlChannelParams' chanName + case (typ < 0, toEnum typ) of + (True, _) -> throwError $ CsStatus (toEnum typ) + (False, CsoundControlChannelClear) -> return Nothing + (False, realTyp) -> return $ Just (realTyp, d, mn, mx) + +setChannelIOCallback :: CsoundChannelIOCallbackT -> Csound () +setChannelIOCallback = io1cm setChannelIOCallback' + +-- **functions for the 'ichannel' family of opcodes +chanIKSet :: + CsndFlt -- ^Value to set + -> Int -- ^Channel number to access. + -> Csound () +chanIKSet val chan = do + csPtr <- ask + csoundStatusWrapper $ chanIKSet' csPtr val chan + +chanOKGet :: + Int -- ^Index of channel + -> Csound CsndFlt -- ^current value of the channel +chanOKGet chan = do + csPtr <- ask + csoundStatValWrapper $ chanOKGet' csPtr chan + +chanIASet :: + [CsndFlt] -- ^Array of value (of length ksmps) to write to a channel + -> Int -- ^Index of channel + -> Csound () +chanIASet ary chan = do + csPtr <- ask + csoundStatusWrapper $ chanIASet' csPtr ary chan + +-- |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 +chanOAGet :: + Int -- ^Length of audio array (ksmps) + -> Int -- ^Index of channel + -> Csound [CsndFlt] +chanOAGet len chan = do + csPtr <- ask + (stat, ptr) <- liftIO $ chanOAGet' csPtr chan + case stat of + CsoundSuccess -> liftIO $ fmap (map cFloatConv) $ peekArray len ptr + err -> throwError $ CsStatus err + +-- **Functions for PvsIn and PvsOut +pvsinSet :: + PvsDatExt -- ^PvsDatExt object to send + -> Int -- ^Index of channel + -> Csound () +pvsinSet pvs chan = do + csPtr <- ask + csoundStatusWrapper $ csoundPvsinSet' csPtr pvs chan + +pvsoutGet :: + Int -- ^Index of channel + -> Csound PvsDatExt +pvsoutGet chan = do + csPtr <- ask + csoundStatValWrapper $ csoundPvsoutGet' csPtr chan + +rand31 :: Int -> Csound Int +rand31 = liftIO . rand31' + +setCallback :: + CsoundCallbackFunction + -> Ptr () + -> CsoundCallbackFunctionTypeMask + -> Csound CsoundSetCallbackStatus +setCallback cfn p mk = do + res <- io3cm setCallback' cfn p mk + case res of + SetCallbackError err -> throwError $ CsStatus err + _ -> return res + +removeCallback :: CsoundCallbackFunction -> Csound () +removeCallback = io1cm removeCallback' + +-- ---------------------------------- +-- Messaging functions +enableMessageBuffer :: Int -> Csound () +enableMessageBuffer = io1cm enableMessageBuffer' + +getFirstMessage :: Csound String +getFirstMessage = io0cm getFirstMessage' + +getFirstMessageAttr :: Csound Int +getFirstMessageAttr = io0cm getFirstMessageAttr' + +popFirstMessage :: Csound () +popFirstMessage = io0cm popFirstMessage' + +getMessageCnt :: Csound Int +getMessageCnt = io0cm getMessageCnt' + +destroyMessageBuffer :: Csound () +destroyMessageBuffer = io0cm destroyMessageBuffer' + +setFileOpenCallback :: CsoundFileOpenCallback -> Csound () +setFileOpenCallback = io1cm setFileOpenCallback' diff --git a/src/Sound/Csound/Vector.hs b/src/Sound/Csound/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Csound/Vector.hs @@ -0,0 +1,119 @@ +module Sound.Csound.Vector ( + -- * Types + BufferWriteStatus (..) + ,CsVector + + -- *Input/output functions + -- ** Spin/spout + ,unsafeVec2Spin + ,vec2Spin + ,readSpout + + -- ** ibuf/obuf + ,unsafeVec2Ibuf + ,vec2Ibuf + ,readObuf + +) + +where + +import Sound.Csound.Interface + +import Data.Vector.Storable (Vector) +import qualified Data.Vector.Storable as V + +import Control.Monad +import Control.Monad.IO.Class +import Foreign + +type CsVector = V.Vector CsndFlt + +-- copy data from first buffer to second +cpPtr :: Storable a => Int -> Ptr a -> Ptr a -> IO () +cpPtr 0 ibuf obuf = return () +cpPtr n ibuf obuf = do + x <- peek ibuf + poke obuf x + cpPtr (n-1) (ibuf `advancePtr` 1) (obuf `advancePtr` 1) + +-- |Result of a buffer write operation +data BufferWriteStatus = + BufOk + | BufferNotFull Int + | DataRemaining CsVector + deriving (Eq, Show) + +-- |Writes a vector to the input buffer. This function doesn't check the +-- length of the buffer before writing. +unsafeVec2Ibuf :: CsVector -> Csound () +unsafeVec2Ibuf vec = do + ibuf <- getInputBuffer + let (vbuf, off, len) = V.unsafeToForeignPtr vec + liftIO . withForeignPtr vbuf $ \ptr -> cpPtr len (ptr `advancePtr` off) ibuf + +-- |Writes a vector to the input buffer. Returns any data remaining in the +-- vector. +vec2Ibuf :: CsVector -> Csound BufferWriteStatus +vec2Ibuf vec = do + isz <- getInputBufferSize + let len = V.length vec + case (len == isz, len > isz) of + (True, _) -> do + unsafeVec2Ibuf vec + return BufOk + (False, True) -> do + unsafeVec2Ibuf $ V.unsafeTake isz vec + return . DataRemaining $ V.unsafeDrop isz vec + (False, False) -> do + unsafeVec2Ibuf vec + return . BufferNotFull $ isz - len + +-- |Reads from obuf to a vector. +readObuf :: Csound CsVector +readObuf = do + bufsz <- getOutputBufferSize + fptr <- liftIO $ mallocForeignPtrArray bufsz + obuf <- getOutputBuffer + liftIO $ withForeignPtr fptr (cpPtr bufsz obuf) + return $ V.unsafeFromForeignPtr fptr 0 bufsz + +-- ---------------------------------- +-- Spin/spout + +-- |Writes a vector to the spin buffer. Doesn't check the buffer length +-- before writing. +unsafeVec2Spin :: CsVector -> Csound () +unsafeVec2Spin vec = do + ibuf <- getSpin + let (vbuf, off, len) = V.unsafeToForeignPtr vec + liftIO . withForeignPtr vbuf $ \ptr -> cpPtr len (ptr `advancePtr` off) ibuf + +-- |Writes a vector to Spin. Returns any data remaining in the vector. +vec2Spin :: CsVector -> Csound BufferWriteStatus +vec2Spin vec = do + ik <- getKsmps + inch <- getNchnls + let isz = ik * inch + let len = V.length vec + case (len == isz, len > isz) of + (True, _) -> do + unsafeVec2Spin vec + return BufOk + (False, True) -> do + unsafeVec2Spin $ V.unsafeTake isz vec + return . DataRemaining $ V.unsafeDrop isz vec + (False, False) -> do + unsafeVec2Spin vec + return . BufferNotFull $ isz - len + +-- |Reads from Spout to a vector. +readSpout :: Csound CsVector +readSpout = do + ik <- getKsmps + inch <- getNchnls + let bufsz = ik * inch + fptr <- liftIO $ mallocForeignPtrArray bufsz + spout <- getSpout + liftIO $ withForeignPtr fptr (cpPtr bufsz spout) + return $ V.unsafeFromForeignPtr fptr 0 bufsz