diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,8 @@ +Copyright (c) 2006 Bjorn Bringert +Copyright (c) 2006 Iavor S. Diatchki + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Sound/Alsa.hs b/Sound/Alsa.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa.hs @@ -0,0 +1,367 @@ +module Sound.Alsa + (SampleFmt(..), + SampleFreq, + SoundFmt(..), + SoundSource(..), + SoundSink(..), + withSoundSource, + withSoundSourceRunning, + withSoundSink, + withSoundSinkRunning, + soundFmtMIME, + audioBytesPerSample, + audioBytesPerFrame, + soundSourceBytesPerFrame, + soundSinkBytesPerFrame, + soundSourceReadBytes, + soundSinkWriteBytes, + copySound, + alsaSoundSource, + alsaSoundSink, + fileSoundSource, + fileSoundSink + ) where + +import Sound.Alsa.Core +import Sound.Alsa.Error + +import Control.Concurrent +import Control.Exception (bracket, bracket_) +import Control.Monad (liftM,when) +import Foreign +import Foreign.C +import System.IO + +-- +-- * Generic sound API +-- + +data SampleFmt = SampleFmtLinear16BitSignedLE + | SampleFmtMuLaw8Bit + deriving (Show) + +type SampleFreq = Int + +data SoundFmt = SoundFmt { + sampleFmt :: SampleFmt, + sampleFreq :: SampleFreq, + numChannels :: Int + } + deriving (Show) + + +-- | Counts are in samples, not bytes. Multi-channel data is interleaved. +data SoundSource handle = + SoundSource { + soundSourceFmt :: SoundFmt, + soundSourceOpen :: IO handle, + soundSourceClose :: handle -> IO (), + soundSourceStart :: handle -> IO (), + soundSourceStop :: handle -> IO (), + soundSourceRead :: handle -> Ptr () -> Int -> IO Int + } + +data SoundSink handle = + SoundSink { + soundSinkFmt :: SoundFmt, + soundSinkOpen :: IO handle, + soundSinkClose :: handle -> IO (), + soundSinkWrite :: handle -> Ptr () -> Int -> IO (), + soundSinkStart :: handle -> IO (), + soundSinkStop :: handle -> IO () + } + +-- +-- +-- + +nullSoundSource :: SoundFmt -> SoundSource h +nullSoundSource fmt = + SoundSource { + soundSourceFmt = fmt, + soundSourceOpen = return undefined, + soundSourceClose = \_ -> return (), + soundSourceStart = \_ -> return (), + soundSourceStop = \_ -> return (), + soundSourceRead = \_ _ _ -> return 0 + } + +nullSoundSink :: SoundFmt -> SoundSink h +nullSoundSink fmt = + SoundSink { + soundSinkFmt = fmt, + soundSinkOpen = return undefined, + soundSinkClose = \_ -> return (), + soundSinkStart = \_ -> return (), + soundSinkStop = \_ -> return (), + soundSinkWrite = \_ _ _ -> return () + } + + +withSoundSource :: SoundSource h -> (h -> IO a) -> IO a +withSoundSource source = + bracket (soundSourceOpen source) (soundSourceClose source) + +withSoundSourceRunning :: SoundSource h -> h -> IO a -> IO a +withSoundSourceRunning src h = bracket_ (soundSourceStart src h) (soundSourceStop src h) + +withSoundSink :: SoundSink h -> (h -> IO a) -> IO a +withSoundSink sink = + bracket (soundSinkOpen sink) (soundSinkClose sink) + +withSoundSinkRunning :: SoundSink h -> h -> IO a -> IO a +withSoundSinkRunning src h = bracket_ (soundSinkStart src h) (soundSinkStop src h) + +soundFmtMIME :: SoundFmt -> String +soundFmtMIME fmt = t ++ r ++ c + where t = case sampleFmt fmt of + SampleFmtLinear16BitSignedLE -> "audio/L16" + SampleFmtMuLaw8Bit -> "audio/basic" + r = ";rate=" ++ show (sampleFreq fmt) + c | numChannels fmt == 1 = "" + | otherwise = ";channels=" ++ show (numChannels fmt) + +audioBytesPerSample :: SoundFmt -> Int +audioBytesPerSample fmt = + case sampleFmt fmt of + SampleFmtLinear16BitSignedLE -> 2 + SampleFmtMuLaw8Bit -> 1 + +-- assumes interleaved data +audioBytesPerFrame :: SoundFmt -> Int +audioBytesPerFrame fmt = numChannels fmt * audioBytesPerSample fmt + +soundSourceBytesPerFrame :: SoundSource h -> Int +soundSourceBytesPerFrame = audioBytesPerFrame . soundSourceFmt + +soundSinkBytesPerFrame :: SoundSink h -> Int +soundSinkBytesPerFrame = audioBytesPerFrame . soundSinkFmt + +soundSourceReadBytes :: SoundSource h -> h -> Ptr () -> Int -> IO Int +soundSourceReadBytes src h buf n = + liftM (* c) $ soundSourceRead src h buf (n `div` c) + where c = soundSourceBytesPerFrame src + +soundSinkWriteBytes :: SoundSink h -> h -> Ptr () -> Int -> IO () +soundSinkWriteBytes src h buf n = + soundSinkWrite src h buf (n `div` c) + where c = soundSinkBytesPerFrame src + +copySound :: SoundSource h1 + -> SoundSink h2 + -> Int -- ^ Buffer size (in bytes) to use + -> IO () +copySound source sink bufSize = + allocaBytes bufSize $ \buf -> + withSoundSource source $ \from -> + withSoundSink sink $ \to -> + let loop = do n <- soundSourceReadBytes source from buf bufSize + when (n > 0) $ do soundSinkWriteBytes sink to buf n + loop + in loop + +-- +-- * Alsa stuff +-- + + +debug s = + do t <- myThreadId + hPutStrLn stderr $ show t ++ ": " ++ s + +alsaOpen :: String -- ^ device, e.g @"default"@ + -> SoundFmt -> PcmStream -> IO Pcm +alsaOpen dev fmt stream = rethrowAlsaExceptions $ + do debug "alsaOpen" + h <- pcm_open dev stream 0 + let buffer_time = 500000 -- 0.5s + period_time = 100000 -- 0.1s + (buffer_time,buffer_size,period_time,period_size) <- + setHwParams h (sampleFmtToPcmFormat (sampleFmt fmt)) + (numChannels fmt) + (sampleFreq fmt) + buffer_time + period_time + setSwParams h buffer_size period_size + pcm_prepare h + debug $ "buffer_time = " ++ show buffer_time + debug $ "buffer_size = " ++ show buffer_size + debug $ "period_time = " ++ show period_time + debug $ "period_size = " ++ show period_size + when (stream == PcmStreamPlayback) $ + callocaBytes (audioBytesPerFrame fmt * period_size) $ \buf -> + do pcm_writei h buf period_size + return () + return h + +sampleFmtToPcmFormat :: SampleFmt -> PcmFormat +sampleFmtToPcmFormat SampleFmtLinear16BitSignedLE = PcmFormatS16Le +sampleFmtToPcmFormat SampleFmtMuLaw8Bit = PcmFormatMuLaw + +setHwParams :: Pcm + -> PcmFormat + -> Int -- ^ number of channels + -> Int -- ^ sample frequency + -> Int -- ^ buffer time + -> Int -- ^ period time + -> IO (Int,Int,Int,Int) + -- ^ (buffer_time,buffer_size,period_time,period_size) +setHwParams h format channels rate buffer_time period_time + = withHwParams h $ \p -> + do pcm_hw_params_set_access h p PcmAccessRwInterleaved + pcm_hw_params_set_format h p format + pcm_hw_params_set_channels h p channels + pcm_hw_params_set_rate h p rate EQ + (buffer_time,_) <- + pcm_hw_params_set_buffer_time_near h p buffer_time EQ + buffer_size <- pcm_hw_params_get_buffer_size p + (period_time,_) <- + pcm_hw_params_set_period_time_near h p period_time EQ + (period_size,_) <- pcm_hw_params_get_period_size p + return (buffer_time,buffer_size,period_time,period_size) + +setSwParams :: Pcm + -> Int -- ^ buffer size + -> Int -- ^ period size + -> IO () +setSwParams h buffer_size period_size = withSwParams h $ \p -> + do let start_threshold = + (buffer_size `div` period_size) * period_size + --pcm_sw_params_set_start_threshold h p start_threshold + pcm_sw_params_set_start_threshold h p 0 + pcm_sw_params_set_avail_min h p period_size + pcm_sw_params_set_xfer_align h p 1 + -- pad buffer with silence when needed + --pcm_sw_params_set_silence_size h p period_size + --pcm_sw_params_set_silence_threshold h p period_size + +withHwParams :: Pcm -> (PcmHwParams -> IO a) -> IO a +withHwParams h f = + do p <- pcm_hw_params_malloc + pcm_hw_params_any h p + x <- f p + pcm_hw_params h p + pcm_hw_params_free p + return x + +withSwParams :: Pcm -> (PcmSwParams -> IO a) -> IO a +withSwParams h f = + do p <- pcm_sw_params_malloc + pcm_sw_params_current h p + x <- f p + pcm_sw_params h p + pcm_sw_params_free p + return x + +alsaClose :: Pcm -> IO () +alsaClose pcm = rethrowAlsaExceptions $ + do debug "alsaClose" + pcm_drain pcm + pcm_close pcm + +alsaStart :: Pcm -> IO () +alsaStart pcm = rethrowAlsaExceptions $ + do debug "alsaStart" + pcm_prepare pcm + pcm_start pcm + + +-- FIXME: use pcm_drain for sinks? +alsaStop :: Pcm -> IO () +alsaStop pcm = rethrowAlsaExceptions $ + do debug "alsaStop" + pcm_drain pcm + +alsaRead :: SoundFmt -> Pcm -> Ptr () -> Int -> IO Int +alsaRead fmt h buf n = rethrowAlsaExceptions $ + do --debug $ "Reading " ++ show n ++ " samples..." + n' <- pcm_readi h buf n `catchXRun` handleOverRun + --debug $ "Got " ++ show n' ++ " samples." + if n' < n + then do n'' <- alsaRead fmt h (buf `plusPtr` (n' * c)) (n - n') + return (n' + n'') + else return n' + where c = audioBytesPerFrame fmt + handleOverRun = do debug "snd_pcm_readi reported buffer over-run" + pcm_prepare h + alsaRead fmt h buf n + +alsaWrite :: SoundFmt -> Pcm -> Ptr () -> Int -> IO () +alsaWrite fmt h buf n = rethrowAlsaExceptions $ + do alsaWrite_ fmt h buf n + return () + +alsaWrite_ :: SoundFmt -> Pcm -> Ptr () -> Int -> IO Int +alsaWrite_ fmt h buf n = + do --debug $ "Writing " ++ show n ++ " samples..." + n' <- pcm_writei h buf n `catchXRun` handleUnderRun + --debug $ "Wrote " ++ show n' ++ " samples." + if (n' /= n) + then do n'' <- alsaWrite_ fmt h (buf `plusPtr` (n' * c)) (n - n') + return (n' + n'') + else return n' + where c = audioBytesPerFrame fmt + handleUnderRun = do debug "snd_pcm_writei reported buffer under-run" + pcm_prepare h + alsaWrite_ fmt h buf n + + +alsaSoundSource :: String -> SoundFmt -> SoundSource Pcm +alsaSoundSource dev fmt = + (nullSoundSource fmt) { + soundSourceOpen = alsaOpen dev fmt PcmStreamCapture, + soundSourceClose = alsaClose, + soundSourceStart = alsaStart, + soundSourceStop = alsaStop, + soundSourceRead = alsaRead fmt + } + +alsaSoundSink :: String -> SoundFmt -> SoundSink Pcm +alsaSoundSink dev fmt = + (nullSoundSink fmt) { + soundSinkOpen = alsaOpen dev fmt PcmStreamPlayback, + soundSinkClose = alsaClose, + soundSinkStart = alsaStart, + soundSinkStop = alsaStop, + soundSinkWrite = alsaWrite fmt + } + +-- +-- * File stuff +-- + +fileRead :: SoundFmt -> Handle -> Ptr () -> Int -> IO Int +fileRead fmt h buf n = liftM (`div` c) $ hGetBuf h buf (n * c) + where c = audioBytesPerSample fmt + +fileWrite :: SoundFmt -> Handle -> Ptr () -> Int -> IO () +fileWrite fmt h buf n = hPutBuf h buf (n * c) + where c = audioBytesPerSample fmt + +fileSoundSource :: FilePath -> SoundFmt -> SoundSource Handle +fileSoundSource file fmt = + (nullSoundSource fmt) { + soundSourceOpen = openBinaryFile file ReadMode, + soundSourceClose = hClose, + soundSourceRead = fileRead fmt + } + +fileSoundSink :: FilePath -> SoundFmt -> SoundSink Handle +fileSoundSink file fmt = + (nullSoundSink fmt) { + soundSinkOpen = openBinaryFile file WriteMode, + soundSinkClose = hClose, + soundSinkWrite = fileWrite fmt + } + +-- +-- * Marshalling utilities +-- + +callocaBytes :: Int -> (Ptr a -> IO b) -> IO b +callocaBytes n f = allocaBytes n (\p -> clearBytes p n >> f p) + +clearBytes :: Ptr a -> Int -> IO () +clearBytes p n = memset p 0 (fromIntegral n) >> return () + +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) diff --git a/Sound/Alsa/C2HS.hs b/Sound/Alsa/C2HS.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/C2HS.hs @@ -0,0 +1,221 @@ +-- 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 Sound.Alsa.C2HS ( + + -- * Re-export the language-independent component of the FFI + module Foreign, + + -- * Re-export the C language component of the FFI + module Foreign.C, + + -- * 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 Foreign.C + +import Control.Monad (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/Sound/Alsa/Core.chs b/Sound/Alsa/Core.chs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Core.chs @@ -0,0 +1,309 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module Sound.Alsa.Core where + +import Sound.Alsa.C2HS +import Sound.Alsa.Error + + + +-- HACK for 32-bit machines. +-- This is only used to be able to parse alsa/pcm.h, +-- since snd_pcm_format_silence_64 use u_int64_t which is not +-- defined on 32-bit machines, AFAICT +#if __WORDSIZE == 32 +typedef unsigned long long int u_int64_t; +#endif + +#include + +{#context prefix = "snd_"#} + +{#pointer *snd_pcm_t as Pcm newtype #} + +instance Storable Pcm where + sizeOf (Pcm r) = sizeOf r + alignment (Pcm r) = alignment r + peek p = fmap Pcm (peek (castPtr p)) + poke p (Pcm r) = poke (castPtr p) r + +{#pointer *snd_pcm_hw_params_t as PcmHwParams newtype #} + +instance Storable PcmHwParams where + sizeOf (PcmHwParams r) = sizeOf r + alignment (PcmHwParams r) = alignment r + peek p = fmap PcmHwParams (peek (castPtr p)) + poke p (PcmHwParams r) = poke (castPtr p) r + +{#pointer *snd_pcm_sw_params_t as PcmSwParams newtype #} + +instance Storable PcmSwParams where + sizeOf (PcmSwParams r) = sizeOf r + alignment (PcmSwParams r) = alignment r + peek p = fmap PcmSwParams (peek (castPtr p)) + poke p (PcmSwParams r) = poke (castPtr p) r + +{#enum _snd_pcm_stream as PcmStream {underscoreToCase} deriving (Eq,Show)#} + +{#enum _snd_pcm_access as PcmAccess {underscoreToCase} deriving (Eq,Show)#} + +{#enum _snd_pcm_format as PcmFormat {underscoreToCase} deriving (Eq,Show)#} + +{#fun pcm_open + { alloca- `Pcm' peek*, + withCString* `String', + cFromEnum `PcmStream', + `Int'} + -> `()' result*- #} + where result = checkResult_ "pcm_open" + +{#fun pcm_close + { id `Pcm' } + -> `()' result*- #} + where result = checkResult_ "pcm_close" + +{#fun pcm_prepare + { id `Pcm' } + -> `()' result*- #} + where result = checkResult_ "pcm_prepare" + +{#fun pcm_start + { id `Pcm' } + -> `()' result*- #} + where result = checkResult_ "pcm_start" + +{#fun pcm_drop + { id `Pcm' } + -> `()' result*- #} + where result = checkResult_ "pcm_drop" + +{#fun pcm_drain + { id `Pcm' } + -> `()' result*- #} + where result = checkResult_ "pcm_drain" + +{- +-- Only available in 1.0.11rc3 and later +{#fun pcm_set_params + { id `Pcm', + cFromEnum `PcmFormat', + cFromEnum `PcmAccess', + `Int', + `Int', + `Bool', + `Int' } + -> `()' result*- #} + where result = checkResult_ "pcm_set_params" +-} + +{#fun pcm_hw_params + { id `Pcm', + id `PcmHwParams' } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params" + +{#fun pcm_hw_params_any + { id `Pcm', + id `PcmHwParams' } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_any" + +{#fun pcm_hw_params_set_access + { id `Pcm', + id `PcmHwParams', + cFromEnum `PcmAccess' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_access" + +{#fun pcm_hw_params_set_format + { id `Pcm', + id `PcmHwParams', + cFromEnum `PcmFormat' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_format" + +{#fun pcm_hw_params_set_rate + { id `Pcm', + id `PcmHwParams', + `Int', + orderingToInt `Ordering' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_rate" + +{- +-- Available in 1.0.9rc2 and later +{#fun pcm_hw_params_set_rate_resample + { id `Pcm', + id `PcmHwParams', + `Bool' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_rate_resample" +-} + +{#fun pcm_hw_params_set_channels + { id `Pcm', + id `PcmHwParams', + `Int' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_channels" + +{#fun pcm_hw_params_set_buffer_size + { id `Pcm', + id `PcmHwParams', + `Int' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_buffer_size" + +{#fun pcm_hw_params_get_buffer_size + { id `PcmHwParams', + alloca- `Int' peekIntConv* + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_get_buffer_size" + +{#fun pcm_hw_params_get_period_size + { id `PcmHwParams', + alloca- `Int' peekIntConv*, + alloca- `Ordering' peekOrdering* + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_get_period_size" + +{#fun pcm_hw_params_set_period_time_near + { id `Pcm', + id `PcmHwParams', + withIntConv* `Int' peekIntConv*, + withOrdering* `Ordering' peekOrdering* + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_period_time_near" + +{#fun pcm_hw_params_set_periods + { id `Pcm', + id `PcmHwParams', + `Int', + orderingToInt `Ordering' + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_periods" + +{#fun pcm_hw_params_set_buffer_time_near + { id `Pcm', + id `PcmHwParams', + withIntConv* `Int' peekIntConv*, + withOrdering* `Ordering' peekOrdering* + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_set_buffer_time_near" + +{#fun pcm_hw_params_get_buffer_time + { id `PcmHwParams', + alloca- `Int' peekIntConv*, + alloca- `Ordering' peekOrdering* + } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_get_buffer_time" + +{#fun pcm_sw_params_set_start_threshold + { id `Pcm', + id `PcmSwParams', + `Int' + } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_set_start_threshold" + +{#fun pcm_sw_params_set_avail_min + { id `Pcm', + id `PcmSwParams', + `Int' + } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_set_avail_min" + +{#fun pcm_sw_params_set_xfer_align + { id `Pcm', + id `PcmSwParams', + `Int' } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_set_xfer_align" + +{#fun pcm_sw_params_set_silence_threshold + { id `Pcm', + id `PcmSwParams', + `Int' } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_set_silence_threshold" + +{#fun pcm_sw_params_set_silence_size + { id `Pcm', + id `PcmSwParams', + `Int' } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_set_silence_size" + +{#fun pcm_readi + { id `Pcm', + castPtr `Ptr a', + `Int' + } + -> `Int' result* #} + where result = fmap fromIntegral . checkResult "pcm_readi" + +{#fun pcm_writei + { id `Pcm', + castPtr `Ptr a', + `Int' + } + -> `Int' result* #} + where result = fmap fromIntegral . checkResult "pcm_writei" + +{#fun pcm_hw_params_malloc + { alloca- `PcmHwParams' peek* } + -> `()' result*- #} + where result = checkResult_ "pcm_hw_params_malloc" + +{#fun pcm_hw_params_free + { id `PcmHwParams' } + -> `()' #} + +{#fun pcm_sw_params_malloc + { alloca- `PcmSwParams' peek* } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_malloc" + +{#fun pcm_sw_params_free + { id `PcmSwParams' } + -> `()' #} + +{#fun pcm_sw_params + { id `Pcm', + id `PcmSwParams' } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params" + +{#fun pcm_sw_params_current + { id `Pcm', + id `PcmSwParams' } + -> `()' result*- #} + where result = checkResult_ "pcm_sw_params_current" + +-- +-- * Marshalling utilities +-- + +orderingToInt :: Ordering -> CInt +orderingToInt o = fromIntegral (fromEnum o - 1) + +intToOrdering :: CInt -> Ordering +intToOrdering i = toEnum (fromIntegral i + 1) + +peekOrdering :: Ptr CInt -> IO Ordering +peekOrdering = fmap intToOrdering . peek + +withOrdering :: Ordering -> (Ptr CInt -> IO a) -> IO a +withOrdering o = with (orderingToInt o) diff --git a/Sound/Alsa/Error.hs b/Sound/Alsa/Error.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Error.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, + DeriveDataTypeable + #-} +module Sound.Alsa.Error where + +import Control.Exception (catchDyn,throwDyn) +import Data.Typeable +import Foreign.C.Error +import Foreign.C.String + +data AlsaException = + AlsaException { exception_location :: String + , exception_description :: String + , exception_code :: Errno + } deriving (Typeable) + +checkResult :: Integral a => String -> a -> IO a +checkResult f r + | r < 0 = throwAlsa f (Errno (negate (fromIntegral r))) + | otherwise = return r + +checkResult_ :: Integral a => String -> a -> IO () +checkResult_ f r = checkResult f r >> return () + +throwAlsa :: String -> Errno -> IO a +throwAlsa fun err = do d <- strerror err + throwDyn AlsaException + { exception_location = fun + , exception_description = d + , exception_code = err + } + +catchAlsa :: IO a -> (AlsaException -> IO a) -> IO a +catchAlsa = catchDyn + +catchAlsaErrno :: Errno + -> IO a -- ^ Action + -> IO a -- ^ Handler + -> IO a +catchAlsaErrno e x h = + catchAlsa x (\ex -> if exception_code ex == e then h else throwDyn ex) + +catchXRun :: IO a -- ^ Action + -> IO a -- ^ Handler + -> IO a +catchXRun = catchAlsaErrno ePIPE + +showAlsaException :: AlsaException -> String +showAlsaException e = exception_location e ++ ": " ++ exception_description e + +-- | Converts any 'AlsaException' into an 'IOError'. +-- This produces better a error message than letting an uncaught +-- 'AlsaException' propagate to the top. +rethrowAlsaExceptions :: IO a -> IO a +rethrowAlsaExceptions x = + catchAlsa x $ \e -> + ioError (errnoToIOError (exception_location e) + (exception_code e) Nothing Nothing) + +-- | Returns the message for an error code. +strerror :: Errno -> IO String +strerror x = peekCString =<< snd_strerror x + +foreign import ccall "alsa/asoundlib.h snd_strerror" + snd_strerror :: Errno -> IO CString + diff --git a/Sound/Alsa/Sequencer.hs b/Sound/Alsa/Sequencer.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer.hs @@ -0,0 +1,132 @@ +------------------------------------------------------------------ +-- | +-- Module : Sound.Alsa.Sequencer +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- Overview: +-- +-- WARNING: This whole library does not seem to be particlarly thread aware. +-- Perhaps place the sequencer handle in an MVar? + +module Sound.Alsa.Sequencer + ( -- * Sequencer + SndSeq + , OpenMode + , open_output + , open_input + , open_duplex + + , BlockMode(..) + + , open + , close + , default_seq_name + , get_seq_name + , set_blocking + + -- ** Manage user-space buffers + , get_output_buffer_size + , set_output_buffer_size + , get_input_buffer_size + , set_input_buffer_size + + -- ** Manage kernel-space memory pools + , set_pool_output + , set_pool_output_room + , reset_pool_output + , set_pool_input + , reset_pool_input + + + -- * Queue Interface + , module Sound.Alsa.Sequencer.Queue + + -- * Client Interface + , module Sound.Alsa.Sequencer.Client + + -- * Port Interface + , module Sound.Alsa.Sequencer.Port + + + -- ** Connections + , connect_from + , connect_to + , disconnect_from + , disconnect_to + + -- * Events + , volume_same + , module Sound.Alsa.Sequencer.Event + + -- ** Types + , RealTime(..) + , TimeStamp(..) + , InstrCluster + , Instr(..) + + , Event(..) + , EventData(..) + , NoteEv(..), Note(..), simple_note + , CtrlEv(..), Ctrl(..) + , AddrEv(..), Addr(..), parse_address, addr_subscribers + , ConnEv(..), Connect + , EmptyEv(..) + + , Sample(..) + , Cluster(..) + , Volume(..) + + + -- * Error handling + , AlsaException + , exception_code, exception_description + , alsa_catch + ) where + +import Data.Word +import Data.Int + +import Sound.Alsa.Sequencer.Marshal +import Sound.Alsa.Sequencer.Errors +import Sound.Alsa.Sequencer.Sequencer +import Sound.Alsa.Sequencer.Client +import Sound.Alsa.Sequencer.Port +import Sound.Alsa.Sequencer.Event +import Sound.Alsa.Sequencer.Queue + + + +-- | The address of all subscribed ports. +addr_subscribers :: Addr +addr_subscribers = Addr { addr_client = client_subscribers + , addr_port = port_unknown + } + + +-- | This is the name that should be passed to 'open' in most cases. +default_seq_name :: String +default_seq_name = "default" + + + +-- | Make a note whose unspecified fields contain 0. +simple_note + :: Word8 -- ^ Channel. + -> Word8 -- ^ Note. + -> Word8 -- ^ Velocity. + -> Note +simple_note c n v = Note { note_channel = c, note_note = n, note_velocity = v + , note_off_velocity = 0, note_duration = 0 + } + + +-- | Used for volume control: means do not change the valume. +volume_same :: Int16 +volume_same = -1 + + + diff --git a/Sound/Alsa/Sequencer/Area.hsc b/Sound/Alsa/Sequencer/Area.hsc new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Area.hsc @@ -0,0 +1,244 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Area +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- PRIVATE MODULE. +-- +-- Here we have macros to deal with the various inforamtion +-- areas present in the library. +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Area where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Sound.Alsa.Sequencer.Errors +import Sound.Alsa.Sequencer.Marshal + +#{let area x,y = +"data "x"_\n" +"newtype "x" = "x" (ForeignPtr "x"_)\n" +"\n" +"with_"y" :: "x" -> (Ptr "x"_ -> IO a) -> IO a\n" +"with_"y" ("x" p) f = withForeignPtr p f\n" +"\n" +"-- | Allocate an uninitiazlied object. (Not exported)\n" +y"_malloc :: IO "x"\n" +y"_malloc = alloca $ \\p ->\n" +" do check_error =<< snd_seq_"y"_malloc p\n" +" "x" `fmap` (newForeignPtr snd_seq_"y"_free =<< peek p)\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_malloc\"\n" +" snd_seq_"y"_malloc :: Ptr (Ptr "x"_) -> IO CInt\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h &snd_seq_"y"_free\"\n" +" snd_seq_"y"_free :: FunPtr (Ptr "x"_ -> IO ())\n" +"\n" +"-- | Copy the content of one object into another.\n" +y"_copy\n" +" :: "x" -- ^ Destination\n" +" -> "x" -- ^ Source\n" +" -> IO ()\n" +"\n" +y"_copy to from =\n" +" with_"y" to $ \\p1 ->\n" +" with_"y" from $ \\p2 ->\n" +" snd_seq_"y"_copy p1 p2\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_copy\"\n" +" snd_seq_"y"_copy :: Ptr "x"_ -> Ptr "x"_ -> IO ()\n" +"\n" +"-- | Copy the content of an object to a newly created object.\n" +y"_clone :: "x" -> IO "x"\n" +y"_clone from =\n" +" do to <- "y"_malloc\n" +" "y"_copy to from\n" +" return to\n" +} + +#{let get_set_name x,y = +y"_get_name :: "x" -> IO String\n" +y"_get_name i = peekCString =<< with_"y" i snd_seq_"y"_get_name\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_get_name\"\n" +" snd_seq_"y"_get_name :: Ptr "x"_ -> IO CString\n" +"\n" +y"_set_name :: "x" -> String -> IO ()\n" +y"_set_name i c =\n" +" withCAString c $ \\p -> with_"y" i (`snd_seq_"y"_set_name` p)\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_set_name\"\n" +" snd_seq_"y"_set_name :: Ptr "x"_ -> CString -> IO ()\n" +} + +#{let get_set_bool x,y,z = +y"_get_"z" :: "x" -> IO Bool\n" +y"_get_"z" i =\n" +" (1 ==) `fmap` with_"y" i snd_seq_"y"_get_"z"\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_get_"z"\"\n" +" snd_seq_"y"_get_"z" :: Ptr "x"_ -> IO CInt\n" +"\n" +y"_set_"z" :: "x" -> Bool -> IO ()\n" +y"_set_"z" i c =\n" +" let x = if c then 1 else 0\n" +" in with_"y" i (`snd_seq_"y"_set_"z"` x)\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_set_"z"\"\n" +" snd_seq_"y"_set_"z" :: Ptr "x"_ -> CInt -> IO ()\n" +} + +#{let get_int x,y,z,t,mk = +y"_get_"z" :: "x" -> IO "t"\n" +y"_get_"z" i =\n" +" "mk"\n" +" `fmap` with_"y" i snd_seq_"y"_get_"z"\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_get_"z"\"\n" +" snd_seq_"y"_get_"z" :: Ptr "x"_ -> IO CInt\n" +} + +#{let set_int x,y,z,t,brk = +y"_set_"z" :: "x" -> "t" -> IO ()\n" +y"_set_"z" i c =\n" +" with_"y" i (`snd_seq_"y"_set_"z"` "brk" c)\n" +"\n" +"foreign import ccall \"alsa/asoundlib.h snd_seq_"y"_set_"z"\"\n" +" snd_seq_"y"_set_"z" :: Ptr "x"_ -> CInt -> IO ()\n" +} + + + +-- Client Info ----------------------------------------------------------------- +#area "ClientInfo", "client_info" + +-- read/write +#get_set_name "ClientInfo", "client_info" +#get_set_bool "ClientInfo", "client_info", "broadcast_filter" +#get_set_bool "ClientInfo", "client_info", "error_bounce" +#{get_int "ClientInfo", "client_info", "client", + "Client", "(imp_Client . fromIntegral)"} +#{set_int "ClientInfo", "client_info", "client", + "Client", "exp_Client"} + +-- read only +#{get_int "ClientInfo", "client_info", "type", + "ClientType", "imp_ClientType"} +#{get_int "ClientInfo", "client_info", "num_ports", + "Word", "fromIntegral"} +#{get_int "ClientInfo", "client_info", "event_lost", + "Word", "fromIntegral"} + + +-- Port Info ------------------------------------------------------------------- +#area "PortInfo", "port_info" + +-- read/write +#get_set_name "PortInfo", "port_info" + +#get_set_bool "PortInfo", "port_info", "port_specified" +#get_set_bool "PortInfo", "port_info", "timestamping" +#get_set_bool "PortInfo", "port_info", "timestamp_real" + +#{get_int "PortInfo", "port_info", "port", + "Port", "(imp_Port . fromIntegral)"} +#{set_int "PortInfo", "port_info", "port", + "Port", "exp_Port"} +#{get_int "PortInfo", "port_info", "client", + "Client","(imp_Client . fromIntegral)"} +#{set_int "PortInfo", "port_info", "client", + "Client","exp_Client"} +#{get_int "PortInfo", "port_info", "capability", + "PortCap","(PortCap . fromIntegral)"} +#{set_int "PortInfo", "port_info", "capability", + "PortCap","(fromIntegral . unPortCap)"} + +#{get_int "PortInfo", "port_info", "midi_channels", + "Word","fromIntegral"} +#{set_int "PortInfo", "port_info", "midi_channels", + "Word","fromIntegral"} +#{get_int "PortInfo", "port_info", "midi_voices", + "Word","fromIntegral"} +#{set_int "PortInfo", "port_info", "midi_voices", + "Word","fromIntegral"} +#{get_int "PortInfo", "port_info", "synth_voices", + "Word","fromIntegral"} +#{set_int "PortInfo", "port_info", "synth_voices", + "Word","fromIntegral"} + +#{get_int "PortInfo", "port_info", "timestamp_queue", + "Queue","(imp_Queue . fromIntegral)"} +#{set_int "PortInfo", "port_info", "timestamp_queue", + "Queue","exp_Queue"} + +-- read only +#{get_int "PortInfo", "port_info", "read_use", + "Word","fromIntegral"} +#{get_int "PortInfo", "port_info", "write_use", + "Word","fromIntegral"} + +-- Queue Info ------------------------------------------------------------------ +#area "QueueInfo", "queue_info" +#get_set_name "QueueInfo", "queue_info" +#get_set_bool "QueueInfo", "queue_info", "locked" + +#{get_int "QueueInfo", "queue_info", "owner", + "Client", "(imp_Client . fromIntegral)"} +#{set_int "QueueInfo", "queue_info", "owner", + "Client", "exp_Client"} +#{get_int "QueueInfo", "queue_info", "flags", + "Word", "fromIntegral"} +#{set_int "QueueInfo", "queue_info", "flags", + "Word", "fromIntegral"} + +-- RO +#{get_int "QueueInfo", "queue_info", "queue", + "Queue","(imp_Queue . fromIntegral)"} + +-- Queue Status ---------------------------------------------------------------- +#area "QueueStatus", "queue_status" + +-- Queue Tempo ----------------------------------------------------------------- +#area "QueueTempo", "queue_tempo" + +-- RO +#{get_int "QueueTempo", "queue_tempo", "queue", + "Queue","(imp_Queue . fromIntegral)"} + +-- RW +#{get_int "QueueTempo", "queue_tempo", "tempo", "Word", "fromIntegral"} +#{set_int "QueueTempo", "queue_tempo", "tempo", "Word", "fromIntegral"} + +#{get_int "QueueTempo", "queue_tempo", "ppq", "Int", "fromIntegral"} +#{set_int "QueueTempo", "queue_tempo", "ppq", "Int", "fromIntegral"} + +#{get_int "QueueTempo", "queue_tempo", "skew", "Word", "fromIntegral"} +#{set_int "QueueTempo", "queue_tempo", "skew", "Word", "fromIntegral"} + +#{get_int "QueueTempo", "queue_tempo", "skew_base", "Word", "fromIntegral"} +#{set_int "QueueTempo", "queue_tempo", "skew_base", "Word", "fromIntegral"} + +-- Queue Timer ----------------------------------------------------------------- +#area "QueueTimer", "queue_timer" + + +-- RO +#{get_int "QueueTimer", "queue_timer", "queue", + "Queue","(imp_Queue . fromIntegral)"} + +-- RW + +#{get_int "QueueTimer", "queue_timer", "type", + "QueueTimerType", "imp_QueueTimerType"} +#{set_int "QueueTimer", "queue_timer", "type", + "QueueTimerType", "exp_QueueTimerType"} + +#{get_int "QueueTimer", "queue_timer", "resolution", "Word", "fromIntegral"} +#{set_int "QueueTimer", "queue_timer", "resolution", "Word", "fromIntegral"} + diff --git a/Sound/Alsa/Sequencer/Client.hs b/Sound/Alsa/Sequencer/Client.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Client.hs @@ -0,0 +1,137 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Client +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- This module contains functions for working with sequencer clients. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Client + ( Client -- :: * + , client_unknown -- :: Client + , client_system -- :: Client + , client_subscribers -- :: Client + , client_broadcast -- :: Client + + , get_client_id -- :: SndSeq -> IO Client + , set_client_name -- :: SndSeq -> String -> IO () + + , ClientInfo -- :: * + , ClientType(..) -- :: * + + , get_client_info -- :: SndSeq -> IO ClientInfo + , get_any_client_info -- :: SndSeq -> Client -> IO ClientInfo + , query_first_client -- :: SndSeq -> IO ClientInfo + , query_next_client -- :: SndSeq -> ClientInfo -> IO Bool + , set_client_info -- :: SndSeq -> ClientInfo -> IO () + + , client_info_copy -- :: ClientInfo -> ClientInfo -> IO () + , client_info_clone -- :: ClientInfo -> IO ClientInfo + + , client_info_get_client -- :: ClientInfo -> IO Client + , client_info_get_type -- :: ClientInfo -> IO ClientType + , client_info_get_name -- :: ClientInfo -> IO String + , client_info_get_broadcast_filter -- :: ClientInfo -> IO Bool + , client_info_get_error_bounce -- :: ClientInfo -> IO Bool + , client_info_get_num_ports -- :: ClientInfo -> IO Word + , client_info_get_event_lost -- :: ClientInfo -> IO Word + + , client_info_set_client -- :: ClientInfo -> Client -> IO () + , client_info_set_name -- :: ClientInfo -> String -> IO () + , client_info_set_broadcast_filter -- :: ClientInfo -> Bool -> IO () + , client_info_set_error_bounce -- :: ClientInfo -> Bool -> IO () + ) where + +import Foreign.C.Types(CInt) +import Foreign.Ptr(Ptr) + +import Control.Monad(guard) + +import Sound.Alsa.Sequencer.Marshal +import Sound.Alsa.Sequencer.Area +import Sound.Alsa.Sequencer.Errors + +-- XXX: Still missing the pool interface. + +-- Convinience functions ------------------------------------------------------- +-- These are part of the "middle" interface, but it seems simple to +-- define them directly in Haskell. + +-- | Get the client identifier for the sequencer. +-- A convinience function. +get_client_id :: SndSeq -> IO Client +get_client_id h = client_info_get_client =<< get_client_info h + +-- | Set the name for the sequencer client. +-- A convinience function. +set_client_name :: SndSeq -> String -> IO () +set_client_name h s = + do i <- get_client_info h + client_info_set_name i s + set_client_info h i + + +-------------------------------------------------------------------------------- + +-- | Create a new information area filled with data about the sequencer client. +get_client_info :: SndSeq -> IO ClientInfo +get_client_info (SndSeq h) = + do info <- client_info_malloc + check_error =<< with_client_info info (snd_seq_get_client_info h) + return info + +foreign import ccall "alsa/asoundlib.h snd_seq_get_client_info" + snd_seq_get_client_info :: Ptr SndSeq_ -> Ptr ClientInfo_ -> IO CInt + + +-- | Create a new information area filled with data about an arbitrary client. +get_any_client_info :: SndSeq -> Client -> IO ClientInfo +get_any_client_info (SndSeq h) c = + do info <- client_info_malloc + check_error =<< with_client_info info + (snd_seq_get_any_client_info h (exp_Client c)) + return info + +foreign import ccall "alsa/asoundlib.h snd_seq_get_any_client_info" + snd_seq_get_any_client_info + :: Ptr SndSeq_ -> CInt -> Ptr ClientInfo_ -> IO CInt + + + +query_first_client :: SndSeq -> IO ClientInfo +query_first_client h = + do x <- client_info_malloc + with_client_info x (`snd_seq_client_info_set_client` (-1)) + b <- query_next_client h x + -- XXX: check that we did get the first client (should be System) + return x + + +-- | Get information about the client with the next biggest identifier. +query_next_client :: SndSeq -> ClientInfo + -> IO Bool -- ^ Was there a next client? +query_next_client (SndSeq h) info = + check_error' (const True) + (\x -> guard (x == -2) >> return False) + =<< with_client_info info (snd_seq_query_next_client h) + +foreign import ccall "alsa/asoundlib.h snd_seq_query_next_client" + snd_seq_query_next_client :: Ptr SndSeq_ -> Ptr ClientInfo_ -> IO CInt + + +-- | Set the information for the sequencer client based on the data +-- in the given information area. +set_client_info :: SndSeq -> ClientInfo -> IO () +set_client_info (SndSeq h) info = + check_error_ =<< with_client_info info (snd_seq_set_client_info h) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_client_info" + snd_seq_set_client_info :: Ptr SndSeq_ -> Ptr ClientInfo_ -> IO CInt + + diff --git a/Sound/Alsa/Sequencer/Errors.hs b/Sound/Alsa/Sequencer/Errors.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Errors.hs @@ -0,0 +1,66 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Errors +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- Working with errors. TODO: Unify with the rest of the ALSA library. +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Errors where + +import Foreign.C.Types(CInt) +import Foreign.C.String(CString,peekCString) +import Control.Exception(throwDyn,catchDyn) +import Data.Word +import Data.Typeable + +data AlsaException = AlsaException + { exception_code :: !Word -- ^ the (positive) error code + , exception_description :: !String -- ^ a text description of the problem + } + +instance Eq AlsaException where + x == y = exception_code x == exception_code y + +instance Ord AlsaException where + compare x y = compare (exception_code x) (exception_code y) + +instance Typeable AlsaException where + typeOf _ = mkTyConApp (mkTyCon "Sound.Alsa.Sequencer.AlsaException") [] + + + +-- | Returns the message for an error code. +strerror :: CInt -> IO String +strerror x = peekCString =<< snd_strerror x + +foreign import ccall "alsa/asoundlib.h snd_strerror" + snd_strerror :: CInt -> IO CString + +-- | Catch an exception generated by the binding. +alsa_catch :: IO a -> (AlsaException -> IO a) -> IO a +alsa_catch = catchDyn + +check_error :: CInt -> IO Word +check_error = check_error' fromIntegral (const Nothing) + +check_error' :: (CInt -> a) -> (CInt -> Maybe a) -> CInt -> IO a +check_error' ok err x + | x >= 0 = return (ok x) + | otherwise = case err x of + Just a -> return a + _ -> do msg <- strerror x + throwDyn AlsaException + { exception_code = fromIntegral (negate x) + , exception_description = msg + } + + + +check_error_ :: CInt -> IO () +check_error_ x = check_error x >> return () + diff --git a/Sound/Alsa/Sequencer/Event.hs b/Sound/Alsa/Sequencer/Event.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Event.hs @@ -0,0 +1,226 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Event +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- This module contains functions for working with events. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Event + ( sync_output_queue -- :: SndSeq -> IO () + , event_input -- :: SndSeq -> IO Event + , event_input_pending -- :: SndSeq -> Bool -> IO Word + , event_output -- :: SndSeq -> Event -> IO Word + , event_output_buffer -- :: SndSeq -> Event -> IO Word + , event_output_direct -- :: SndSeq -> Event -> IO Word + , event_output_pending -- :: SndSeq -> IO Word + , extract_output -- :: SndSeq -> IO Event + , remove_output -- :: SndSeq -> IO () + , drain_output -- :: SndSeq -> IO Word + , drop_output -- :: SndSeq -> IO () + , drop_output_buffer -- :: SndSeq -> IO () + , drop_input -- :: SndSeq -> IO () + , drop_input_buffer -- :: SndSeq -> IO () + ) where + + +import Foreign.C.Types(CInt) +import Foreign.Ptr(Ptr,nullPtr) +import Foreign.Marshal.Alloc(alloca) +import Foreign.Storable + +import Data.Word +import Data.Int + +import Sound.Alsa.Sequencer.Marshal +import Sound.Alsa.Sequencer.Errors + + +-- | Wait until all events of the client are processed. +sync_output_queue :: SndSeq -> IO () +sync_output_queue (SndSeq h) = + check_error_ =<< snd_seq_sync_output_queue h + +foreign import ccall "alsa/asoundlib.h snd_seq_sync_output_queue" + snd_seq_sync_output_queue :: Ptr SndSeq_ -> IO CInt + + +-- | Get an event from the input buffer. +-- If the input buffer is empty, then it is filled with data from the +-- sequencer queue. If there is no data in the sequencer queue, +-- then the process is either put to sleep (if the sequencer is operating +-- in blocking mode), or we throw @EAGAIN@ (if the sequence is operating +-- in non-blocking mode). +-- +-- We may also throw @ENOSPC@, which means that the sequencer queue +-- over-run and some events were lost (this clears the input buffer). +-- +event_input :: SndSeq -> IO Event +event_input (SndSeq h) = alloca $ \p -> + do check_error =<< snd_seq_event_input h p + peek =<< peek p + +foreign import ccall "alsa/asoundlib.h snd_seq_event_input" + snd_seq_event_input :: Ptr SndSeq_ -> Ptr (Ptr Event) -> IO CInt + + +-- | Returns the number of events in the input buffer. +-- If the input buffer is empty and the boolean argument is true, +-- then try to fill the input buffer with data from the sequencer queue. +-- See also: 'snd_seq_event_input'. + +event_input_pending + :: SndSeq + -> Bool -- ^ refill if empty? + -> IO Word -- ^ number of events in buffer +event_input_pending (SndSeq h) fill = + check_error =<< snd_seq_event_input_pending h (if fill then 1 else 0) + +foreign import ccall "alsa/asoundlib.h snd_seq_event_input_pending" + snd_seq_event_input_pending :: Ptr SndSeq_ -> Int -> IO CInt + + + +-- | Output an event and drain the buffer, if it became full. +-- Throws exceptions. +-- See also: 'event_output_direct', 'event_output_buffer', +-- 'event_output_pending', 'drain_output', 'drop_output', +-- 'extract_output', 'remove_events' + +event_output :: SndSeq + -> Event + -> IO Word -- ^ the number of remaining events (or bytes?) +event_output (SndSeq h) e = + alloca_ev e $ \p -> check_error =<< snd_seq_event_output h p + +foreign import ccall "alsa/asoundlib.h snd_seq_event_output " + snd_seq_event_output :: Ptr SndSeq_ -> Ptr Event -> IO CInt + + + +-- | Output an event without draining the buffer. +-- Throws @-EAGAIN@ if the buffer becomes full. +-- See also 'event_output'. + +event_output_buffer :: SndSeq + -> Event + -> IO Word -- ^ the byte size of remaining events + +event_output_buffer (SndSeq h) e = + alloca_ev e $ \p -> check_error =<< snd_seq_event_output_buffer h p + +foreign import ccall "alsa/asoundlib.h snd_seq_event_output_buffer" + snd_seq_event_output_buffer :: Ptr SndSeq_ -> Ptr Event -> IO CInt + + +-- | Output an event directly to the sequencer, NOT through the output buffer. +-- If an error occurs, then we throw an exception. +-- See also 'event_output'. + +event_output_direct + :: SndSeq + -> Event + -> IO Word -- ^ number of bytes sent to the sequencer + +event_output_direct (SndSeq h) e = + alloca_ev e $ \p -> check_error =<< snd_seq_event_output_direct h p + +foreign import ccall "alsa/asoundlib.h snd_seq_event_output_direct" + snd_seq_event_output_direct :: Ptr SndSeq_ -> Ptr Event -> IO CInt + + +-- | Return the size (in bytes) of pending events on output buffer. +-- See also 'snd_seq_event_output'. +event_output_pending + :: SndSeq + -> IO Word -- ^ size of pending events (in bytes) +event_output_pending (SndSeq h) = + fromIntegral `fmap` snd_seq_event_output_pending h + +foreign import ccall "alsa/asoundlib.h snd_seq_event_output_pending" + snd_seq_event_output_pending :: Ptr SndSeq_ -> IO CInt + + +-- | Extract the first event in output buffer. +-- Throws an exception on error. +-- See also 'snd_seq_event_output'. +extract_output + :: SndSeq + -> IO Event -- ^ the first event in the buffer (if one was present) +extract_output (SndSeq h) = + alloca $ \p -> do check_error =<< snd_seq_extract_output h p + peek =<< peek p + +-- | Remove the first event in output buffer. +-- Throws an exception on error. +-- See also 'snd_seq_event_output'. +remove_output :: SndSeq -> IO () +remove_output (SndSeq h) = check_error_ =<< snd_seq_extract_output h nullPtr + +foreign import ccall "alsa/asoundlib.h snd_seq_extract_output" + snd_seq_extract_output :: Ptr SndSeq_ -> Ptr (Ptr Event) -> IO CInt + + +-- | Drain output buffer to sequencer. +-- This function drains all pending events on the output buffer. +-- The function returns immediately after the events are sent to the queues +-- regardless whether the events are processed or not. +-- To get synchronization with the all event processes, +-- use 'sync_output_queue' after calling this function. +-- Throws an exception on error. +-- See also: 'event_output', 'sync_output_queue'. + +drain_output + :: SndSeq + -> IO Word -- ^ byte size of events remaining in the buffer. + +drain_output (SndSeq h) = check_error =<< snd_seq_drain_output h + +foreign import ccall "alsa/asoundlib.h snd_seq_drain_output" + snd_seq_drain_output :: Ptr SndSeq_ -> IO CInt + + +-- | Remove events from both the user-space output buffer, +-- and the kernel-space sequencer queue. +-- See also: 'drain_output', 'drop_output_buffer', 'remove_events'. +drop_output :: SndSeq -> IO () +drop_output (SndSeq h) = check_error_ =<< snd_seq_drop_output h + +foreign import ccall "alsa/asoundlib.h snd_seq_drop_output" + snd_seq_drop_output :: Ptr SndSeq_ -> IO CInt + + +-- | Remove events from the user-space output buffer. +-- See also: 'drop_output'. +drop_output_buffer :: SndSeq -> IO () +drop_output_buffer (SndSeq h) = check_error_ =<< snd_seq_drop_output_buffer h + +foreign import ccall "alsa/asoundlib.h snd_seq_drop_output_buffer" + snd_seq_drop_output_buffer :: Ptr SndSeq_ -> IO CInt + + +-- | Remove events from both the user-space input buffer, +-- and the kernel-space sequencer queue. +-- See also: 'drop_input_buffer', 'remove_events'. +drop_input :: SndSeq -> IO () +drop_input (SndSeq h) = check_error_ =<< snd_seq_drop_input h + +foreign import ccall "alsa/asoundlib.h snd_seq_drop_input" + snd_seq_drop_input :: Ptr SndSeq_ -> IO CInt + + +-- | Remove events from the user-space input buffer. +-- See also: 'drop_input'. +drop_input_buffer :: SndSeq -> IO () +drop_input_buffer (SndSeq h) = check_error_ =<< snd_seq_drop_input_buffer h + +foreign import ccall "alsa/asoundlib.h snd_seq_drop_input_buffer" + snd_seq_drop_input_buffer :: Ptr SndSeq_ -> IO CInt + + diff --git a/Sound/Alsa/Sequencer/Marshal.hsc b/Sound/Alsa/Sequencer/Marshal.hsc new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Marshal.hsc @@ -0,0 +1,641 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Marshal +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- PRIVATE MODULE. +-- +-- Here we have the various types used by the library, +-- and how they are imported\/exported to C. +-- +-- NOTE: In the translations bellow we make the following assumptions +-- about the sizes of C types. +-- CChar = 8 bits +-- CShort = 16 bit +-- CInt = 32 bits +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Marshal where + +#include +import Foreign +import Foreign.C.Types +import Data.Word +import Data.Array + + +-- | Read\/Write permissions for the sequencer device. +newtype OpenMode = OpenMode CInt deriving (Show,Eq,Ord,Storable) + +#{enum OpenMode, OpenMode + , open_output = SND_SEQ_OPEN_OUTPUT + , open_input = SND_SEQ_OPEN_INPUT + , open_duplex = SND_SEQ_OPEN_DUPLEX + } + +exp_OpenMode :: OpenMode -> CInt +exp_OpenMode (OpenMode x) = x + +-- | Blocking behavior of the sequencer device. +data BlockMode = Block -- ^ Operations may block. + | Nonblock -- ^ Throw exceptions instead of blocking. + deriving (Show,Eq) + +exp_BlockMode :: BlockMode -> CInt +exp_BlockMode x = case x of + Block -> 0 + Nonblock -> #{const SND_SEQ_NONBLOCK} + + +-- | The type of sequencer handles. +newtype SndSeq = SndSeq (Ptr SndSeq_) deriving Eq +data SndSeq_ + + +-- | The type of client identifiers. +newtype Client = Client Word8 deriving (Show,Eq,Ord,Storable) + + +#{enum Client, Client + , client_system = SND_SEQ_CLIENT_SYSTEM + , client_subscribers = SND_SEQ_ADDRESS_SUBSCRIBERS + , client_broadcast = SND_SEQ_ADDRESS_BROADCAST + , client_unknown = SND_SEQ_ADDRESS_UNKNOWN + } + + + +exp_Client :: Client -> CInt +exp_Client (Client c) = fromIntegral c + +imp_Client :: Word -> Client +imp_Client p = Client (fromIntegral p) + +-- | The different types of clients. +data ClientType = UserClient | KernelClient + +imp_ClientType :: CInt -> ClientType +imp_ClientType x = if x == #{const SND_SEQ_USER_CLIENT} then UserClient + else KernelClient + +-- | Port capabilities. +newtype PortCap = PortCap { unPortCap :: CUInt } deriving (Eq,Ord) + +-- | Port types. +newtype PortType = PortType { unPortType :: CUInt } deriving (Eq,Ord) + +#{enum Port, Port + , port_system_timer = SND_SEQ_PORT_SYSTEM_TIMER + , port_system_announce = SND_SEQ_PORT_SYSTEM_ANNOUNCE + , port_unknown = SND_SEQ_ADDRESS_UNKNOWN + } + +#{enum PortCap, PortCap + , cap_read = SND_SEQ_PORT_CAP_READ + , cap_write = SND_SEQ_PORT_CAP_WRITE + , cap_sync_read = SND_SEQ_PORT_CAP_SYNC_READ + , cap_sync_write = SND_SEQ_PORT_CAP_SYNC_WRITE + , cap_duplex = SND_SEQ_PORT_CAP_DUPLEX + , cap_subs_read = SND_SEQ_PORT_CAP_SUBS_READ + , cap_subs_write = SND_SEQ_PORT_CAP_SUBS_WRITE + , cap_no_export = SND_SEQ_PORT_CAP_NO_EXPORT + } + +caps :: [PortCap] -> PortCap +caps cs = PortCap (foldl (.|.) 0 (map unPortCap cs)) + +#{enum PortType, PortType + , type_specific = SND_SEQ_PORT_TYPE_SPECIFIC + , type_midi_generic = SND_SEQ_PORT_TYPE_MIDI_GENERIC + , type_midi_gm = SND_SEQ_PORT_TYPE_MIDI_GM + , type_midi_gs = SND_SEQ_PORT_TYPE_MIDI_GS + , type_midi_xg = SND_SEQ_PORT_TYPE_MIDI_XG + , type_midi_mt32 = SND_SEQ_PORT_TYPE_MIDI_MT32 + , type_midi_gm2 = SND_SEQ_PORT_TYPE_MIDI_GM2 + + , type_synth = SND_SEQ_PORT_TYPE_SYNTH + , type_direct_sample = SND_SEQ_PORT_TYPE_DIRECT_SAMPLE + , type_sample = SND_SEQ_PORT_TYPE_SAMPLE + + , type_hardware = SND_SEQ_PORT_TYPE_HARDWARE + , type_software = SND_SEQ_PORT_TYPE_SOFTWARE + , type_synthesizer = SND_SEQ_PORT_TYPE_SYNTHESIZER + , type_port = SND_SEQ_PORT_TYPE_PORT + , type_application = SND_SEQ_PORT_TYPE_APPLICATION + } + +types :: [PortType] -> PortType +types cs = PortType (foldl (.|.) 0 (map unPortType cs)) + + + + + +-- The type of queue identifiers. +newtype Queue = Queue Word8 deriving (Show,Eq,Ord,Storable) + +imp_Queue :: Word -> Queue +imp_Queue x = Queue (fromIntegral x) + +exp_Queue :: Queue -> CInt +exp_Queue (Queue x) = fromIntegral x + +#{enum Queue, Queue + , queue_direct = SND_SEQ_QUEUE_DIRECT + } + +data QueueTimerType = TimerAlsa + | TimerMidiClock + | TimerMidiTick + +exp_QueueTimerType :: QueueTimerType -> CInt +exp_QueueTimerType t = case t of + TimerAlsa -> #{const SND_SEQ_TIMER_ALSA} + TimerMidiClock -> #{const SND_SEQ_TIMER_MIDI_CLOCK} + TimerMidiTick -> #{const SND_SEQ_TIMER_MIDI_TICK} + +imp_QueueTimerType :: CInt -> QueueTimerType +imp_QueueTimerType t = case t of + #{const SND_SEQ_TIMER_ALSA} -> TimerAlsa + #{const SND_SEQ_TIMER_MIDI_CLOCK} -> TimerMidiClock + #{const SND_SEQ_TIMER_MIDI_TICK} -> TimerMidiTick + _ -> error ("imp_QueueTimerType: unknown timer type (" ++ show t ++ ")") + + +-- The type of client ports. +newtype Port = Port Word8 deriving (Show,Eq,Ord,Storable) + +exp_Port :: Port -> CInt +exp_Port (Port p) = fromIntegral p + +imp_Port :: Word -> Port +imp_Port p = Port (fromIntegral p) + + +data Addr = Addr { addr_client :: !Client + , addr_port :: !Port + } deriving (Show,Eq,Ord) + +exp_Addr :: Addr -> (CInt,CInt) +exp_Addr a = (exp_Client (addr_client a), exp_Port (addr_port a)) + + +instance Storable Addr where + sizeOf _ = #size snd_seq_real_time_t + alignment _ = 4 -- XXX + peek p = do cl <- #{peek snd_seq_addr_t, client} p + po <- #{peek snd_seq_addr_t, port} p + return Addr { addr_client = cl, addr_port = po } + poke p v = #{poke snd_seq_addr_t, client} p (addr_client v) + >> #{poke snd_seq_addr_t, port} p (addr_port v) + + +data Connect = Connect { conn_source :: !Addr + , conn_dest :: !Addr + } deriving (Show,Eq,Ord) + +instance Storable Connect where + sizeOf _ = #size snd_seq_connect_t + alignment _ = 4 -- XXX + peek p = do s <- #{peek snd_seq_connect_t, sender} p + d <- #{peek snd_seq_connect_t, dest} p + return Connect { conn_source = s, conn_dest = d } + poke p v = #{poke snd_seq_connect_t, sender} p (conn_source v) + >> #{poke snd_seq_connect_t, dest} p (conn_dest v) + + +-- XXX: to compare these we should first normalize them +data RealTime = RT { rt_secs :: !Word32 + , rt_nano :: !Word32 + } deriving (Show) + +instance Storable RealTime where + sizeOf _ = #{size snd_seq_real_time_t} + alignment _ = 4 -- XXX + peek p = do s <- #{peek snd_seq_real_time_t, tv_sec} p + n <- #{peek snd_seq_real_time_t, tv_nsec} p + return RT { rt_secs = s, rt_nano = n } + poke p v = #{poke snd_seq_real_time_t, tv_sec} p (rt_secs v) + >> #{poke snd_seq_real_time_t, tv_nsec} p (rt_nano v) + + +data TimeStamp = TickTime !Word32 + | RealTime !RealTime + deriving Show + +peek_timestamp :: Word8 -> Ptr TimeStamp -> IO TimeStamp +peek_timestamp flags p = + case flags .&. #{const SND_SEQ_TIME_STAMP_MASK} of + { #{const SND_SEQ_TIME_STAMP_TICK} -> TickTime `fmap` peek (castPtr p) + ; _ -> RealTime `fmap` peek (castPtr p) + } + +poke_timestamp :: Ptr TimeStamp -> TimeStamp -> IO Word8 +poke_timestamp p ts = case ts of + TickTime t -> poke (castPtr p) t >> return #{const SND_SEQ_TIME_STAMP_TICK} + RealTime t -> poke (castPtr p) t >> return #{const SND_SEQ_TIME_STAMP_REAL} + + + +newtype InstrCluster = InstrCluster CUInt + deriving (Show,Eq,Ord,Num,Enum,Storable) + +data Instr = Instr { instr_cluster :: !InstrCluster + -- XXX: perhaps use Smaple? + , instr_std :: !Word32 + , instr_bank :: !Word16 + , instr_prg :: !Word16 + } deriving (Show) + +{- +instance Storable Instr where + sizeOf _ = #{size snd_seq_instr_t} + alignment _ = 4 -- XXX + peek p = do cl <- #{peek snd_seq_instr_t, cluster} p + st <- #{peek snd_seq_instr_t, std} p + ba <- #{peek snd_seq_instr_t, bank} p + pr <- #{peek snd_seq_instr_t, prg} p + return Instr { instr_cluster = cl + , instr_std = st + , instr_bank = ba + , instr_prg = pr + } + poke p v = #{poke snd_seq_instr_t, cluster} p (instr_cluster v) + >> #{poke snd_seq_instr_t, std} p (instr_std v) + >> #{poke snd_seq_instr_t, bank} p (instr_bank v) + >> #{poke snd_seq_instr_t, prg} p (instr_prg v) +-} + + +data Note = Note { note_channel :: !Word8 + , note_note :: !Word8 + , note_velocity :: !Word8 + , note_off_velocity :: !Word8 + , note_duration :: !Word32 + } deriving (Show) + + +instance Storable Note where + sizeOf _ = #{size snd_seq_ev_note_t} + alignment _ = 4 -- XXX + peek p = do c <- #{peek snd_seq_ev_note_t, channel} p + n <- #{peek snd_seq_ev_note_t, note} p + v <- #{peek snd_seq_ev_note_t, velocity} p + ov <- #{peek snd_seq_ev_note_t, off_velocity} p + d <- #{peek snd_seq_ev_note_t, duration} p + return Note { note_channel = c + , note_note = n + , note_velocity = v + , note_off_velocity = ov + , note_duration = d + } + poke p v = #{poke snd_seq_ev_note_t, channel} p (note_channel v) + >> #{poke snd_seq_ev_note_t, note} p (note_note v) + >> #{poke snd_seq_ev_note_t, velocity} p (note_velocity v) + >> #{poke snd_seq_ev_note_t, off_velocity} p (note_off_velocity v) + >> #{poke snd_seq_ev_note_t, duration} p (note_duration v) + + +data Ctrl = Ctrl { ctrl_channel :: !Word8 + , ctrl_param :: !Word32 + , ctrl_value :: !Int32 + } deriving (Show) + +instance Storable Ctrl where + sizeOf _ = #{size snd_seq_ev_ctrl_t} + alignment _ = 4 -- XXX + peek p = do ct <- #{peek snd_seq_ev_ctrl_t, channel} p + pa <- #{peek snd_seq_ev_ctrl_t, param} p + va <- #{peek snd_seq_ev_ctrl_t, value} p + return Ctrl { ctrl_channel = ct + , ctrl_param = pa + , ctrl_value = va + } + poke p v = #{poke snd_seq_ev_ctrl_t, channel} p (ctrl_channel v) + >> #{poke snd_seq_ev_ctrl_t, param} p (ctrl_param v) + >> #{poke snd_seq_ev_ctrl_t, value} p (ctrl_value v) + + + +data Sample = Sample { sample_std :: !Word32 + , sample_bank :: !Word16 + , sample_prg :: !Word16 + } deriving (Show) + +{- +instance Storable Sample where + sizeOf _ = #{size snd_seq_ev_sample_t} + alignment _ = 4 -- XXX + peek p = do st <- #{peek snd_seq_ev_sample_t, std} p + ba <- #{peek snd_seq_ev_sample_t, bank} p + pr <- #{peek snd_seq_ev_sample_t, prg} p + return Sample { sample_std = st + , sample_bank = ba + , sample_prg = pr + } + poke p v = #{poke snd_seq_ev_sample_t, std} p (sample_std v) + >> #{poke snd_seq_ev_sample_t, bank} p (sample_bank v) + >> #{poke snd_seq_ev_sample_t, prg} p (sample_prg v) +-} + + +newtype Cluster = Cluster { cluster_cluster :: InstrCluster + } deriving (Show,Eq,Storable) + + +-- | These are all 14 bit values. +data Volume = Volume { volume_volume :: !Int16 + , volume_lr :: !Int16 + , volume_fr :: !Int16 + , volume_du :: !Int16 + } deriving (Show) + +{- +instance Storable Volume where + sizeOf _ = #{size snd_seq_ev_volume_t} + alignment _ = 4 -- XXX + peek p = do v <- #{peek snd_seq_ev_volume_t, volume} p + l <- #{peek snd_seq_ev_volume_t, lr} p + f <- #{peek snd_seq_ev_volume_t, fr} p + d <- #{peek snd_seq_ev_volume_t, du} p + return Volume { volume_volume = v + , volume_lr = l + , volume_fr = f + , volume_du = d + } + poke p v = #{poke snd_seq_ev_volume_t, volume} p (volume_volume v) + >> #{poke snd_seq_ev_volume_t, lr} p (volume_lr v) + >> #{poke snd_seq_ev_volume_t, fr} p (volume_fr v) + >> #{poke snd_seq_ev_volume_t, du} p (volume_du v) +-} + + +data Event = Event { ev_high_priority :: !Bool + , ev_tag :: !Word8 + , ev_queue :: !Queue + , ev_timestamp :: !TimeStamp + , ev_source :: !Addr + , ev_dest :: !Addr + , ev_data :: !EventData + } deriving Show + +instance Storable Event where + sizeOf _ = #{size snd_seq_event_t} + alignment _ = 4 -- XXX + peek p = + do ty <- #{peek snd_seq_event_t, type} p + flags <- #{peek snd_seq_event_t, flags} p + tag <- #{peek snd_seq_event_t, tag} p + q <- #{peek snd_seq_event_t, queue} p + time <- peek_timestamp flags (#{ptr snd_seq_event_t, time} p) + src <- #{peek snd_seq_event_t, source} p + dest <- #{peek snd_seq_event_t, dest} p + d <- (peek_event_data ! ty) (#{ptr snd_seq_event_t, data} p) + return Event + { ev_high_priority = (flags .&. #{const SND_SEQ_PRIORITY_MASK}) /= 0 + , ev_tag = tag + , ev_queue = q + , ev_timestamp = time + , ev_source = src + , ev_dest = dest + , ev_data = d + } + poke p e = do + { ty <- poke_event_data (#{ptr snd_seq_event_t, data} p) (ev_data e) + ; #{poke snd_seq_event_t, type} p ty + ; #{poke snd_seq_event_t, tag} p (ev_tag e) + ; #{poke snd_seq_event_t, queue} p (ev_queue e) + ; real <- poke_timestamp (#{ptr snd_seq_event_t, time} p) (ev_timestamp e) + ; #{poke snd_seq_event_t, source} p (ev_source e) + ; #{poke snd_seq_event_t, dest} p (ev_dest e) + ; let flags = (if ev_high_priority e + then #{const SND_SEQ_PRIORITY_HIGH} + else #{const SND_SEQ_PRIORITY_NORMAL}) + .|. real + .|. #{const SND_SEQ_EVENT_LENGTH_FIXED} -- XXX + ; #{poke snd_seq_event_t, flags} p flags + } + +alloca_ev :: Event -> (Ptr Event -> IO a) -> IO a +alloca_ev e h = alloca (\p -> poke p e >> h p) + +poke_event_data :: Ptr EventData -> EventData -> IO Word8 +poke_event_data p dt = case dt of + NoteEv e d -> poke (castPtr p) d >> return (exp_note_ev e) + CtrlEv e d -> poke (castPtr p) d >> return (exp_ctrl_ev e) + AddrEv e d -> poke (castPtr p) d >> return (exp_addr_ev e) + ConnEv e d -> poke (castPtr p) d >> return (exp_conn_ev e) + EmptyEv e -> return (exp_empty_ev e) + + +peek_event_data :: Array Word8 (Ptr EventData -> IO EventData) +peek_event_data = accumArray (const id) unknown (0,255) + [ -- result events (2) + (#{const SND_SEQ_EVENT_SYSTEM}, unknown) + , (#{const SND_SEQ_EVENT_RESULT}, unknown) + + -- note events (4) + , (#{const SND_SEQ_EVENT_NOTE}, peek_note_ev ANote) + , (#{const SND_SEQ_EVENT_NOTEON}, peek_note_ev NoteOn) + , (#{const SND_SEQ_EVENT_NOTEOFF}, peek_note_ev NoteOff) + , (#{const SND_SEQ_EVENT_KEYPRESS}, peek_note_ev KeyPress) + + -- control events (12) + , (#{const SND_SEQ_EVENT_CONTROLLER}, peek_ctrl_ev Controller) + , (#{const SND_SEQ_EVENT_PGMCHANGE}, peek_ctrl_ev PgmChange) + , (#{const SND_SEQ_EVENT_CHANPRESS}, peek_ctrl_ev ChanPress) + , (#{const SND_SEQ_EVENT_PITCHBEND}, peek_ctrl_ev PitchBend) + , (#{const SND_SEQ_EVENT_CONTROL14}, peek_ctrl_ev Control14) + , (#{const SND_SEQ_EVENT_NONREGPARAM}, peek_ctrl_ev NonRegParam) + , (#{const SND_SEQ_EVENT_REGPARAM}, peek_ctrl_ev RegParam) + , (#{const SND_SEQ_EVENT_SONGPOS}, peek_ctrl_ev SongPos) + , (#{const SND_SEQ_EVENT_SONGSEL}, peek_ctrl_ev SongSel) + , (#{const SND_SEQ_EVENT_QFRAME}, peek_ctrl_ev QFrame) + , (#{const SND_SEQ_EVENT_TIMESIGN}, peek_ctrl_ev TimeSign) + , (#{const SND_SEQ_EVENT_KEYSIGN}, peek_ctrl_ev KeySign) + + -- queue control (10) + , (#{const SND_SEQ_EVENT_START}, unknown) + , (#{const SND_SEQ_EVENT_CONTINUE}, unknown) + , (#{const SND_SEQ_EVENT_STOP}, unknown) + , (#{const SND_SEQ_EVENT_SETPOS_TICK}, unknown) + , (#{const SND_SEQ_EVENT_SETPOS_TIME}, unknown) + , (#{const SND_SEQ_EVENT_TEMPO}, unknown) + , (#{const SND_SEQ_EVENT_CLOCK}, unknown) + , (#{const SND_SEQ_EVENT_TICK}, unknown) + , (#{const SND_SEQ_EVENT_QUEUE_SKEW}, unknown) + , (#{const SND_SEQ_EVENT_SYNC_POS}, unknown) + + -- misc (3) + , (#{const SND_SEQ_EVENT_TUNE_REQUEST}, peek_empty_ev TuneRequest) + , (#{const SND_SEQ_EVENT_RESET}, peek_empty_ev Reset) + , (#{const SND_SEQ_EVENT_SENSING}, peek_empty_ev Sensing) + + , (#{const SND_SEQ_EVENT_ECHO}, unknown) + , (#{const SND_SEQ_EVENT_OSS}, unknown) + + -- networking (8) + , (#{const SND_SEQ_EVENT_CLIENT_START}, peek_addr_ev ClientStart) + , (#{const SND_SEQ_EVENT_CLIENT_EXIT}, peek_addr_ev ClientExit) + , (#{const SND_SEQ_EVENT_CLIENT_CHANGE}, peek_addr_ev ClientChange) + , (#{const SND_SEQ_EVENT_PORT_START}, peek_addr_ev PortStart) + , (#{const SND_SEQ_EVENT_PORT_EXIT}, peek_addr_ev PortExit) + , (#{const SND_SEQ_EVENT_PORT_CHANGE}, peek_addr_ev PortChange) + , (#{const SND_SEQ_EVENT_PORT_SUBSCRIBED}, peek_conn_ev PortSubscribed) + , (#{const SND_SEQ_EVENT_PORT_UNSUBSCRIBED}, peek_conn_ev PortUnsubscribed) + +{- + , (#{const SND_SEQ_EVENT_SAMPLE}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_CLUSTER}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_START}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_STOP}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_FREQ}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_VOLUME}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_LOOP}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_POSITION}, unknown) + , (#{const SND_SEQ_EVENT_SAMPLE_PRIVATE1}, unknown) +-} + , (#{const SND_SEQ_EVENT_USR0}, unknown) + , (#{const SND_SEQ_EVENT_USR1}, unknown) + , (#{const SND_SEQ_EVENT_USR2}, unknown) + , (#{const SND_SEQ_EVENT_USR3}, unknown) + , (#{const SND_SEQ_EVENT_USR4}, unknown) + , (#{const SND_SEQ_EVENT_USR5}, unknown) + , (#{const SND_SEQ_EVENT_USR6}, unknown) + , (#{const SND_SEQ_EVENT_USR7}, unknown) + , (#{const SND_SEQ_EVENT_USR8}, unknown) + , (#{const SND_SEQ_EVENT_USR9}, unknown) + +{- + , (#{const SND_SEQ_EVENT_INSTR_BEGIN}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_END}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_INFO}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_INFO_RESULT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_FINFO}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_FINFO_RESULT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_RESET}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_STATUS}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_STATUS_RESULT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_PUT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_GET}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_GET_RESULT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_FREE}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_LIST}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_LIST_RESULT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_CLUSTER}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_CLUSTER_GET}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_CLUSTER_RESULT}, unknown) + , (#{const SND_SEQ_EVENT_INSTR_CHANGE}, unknown) +-} + + , (#{const SND_SEQ_EVENT_SYSEX}, unknown) + , (#{const SND_SEQ_EVENT_BOUNCE}, unknown) + + , (#{const SND_SEQ_EVENT_USR_VAR0}, unknown) + , (#{const SND_SEQ_EVENT_USR_VAR1}, unknown) + , (#{const SND_SEQ_EVENT_USR_VAR2}, unknown) + , (#{const SND_SEQ_EVENT_USR_VAR3}, unknown) + , (#{const SND_SEQ_EVENT_USR_VAR3}, unknown) + + , (#{const SND_SEQ_EVENT_NONE}, peek_empty_ev None) + ] + + where unknown = peek_empty_ev Unknown + + +data NoteEv = ANote | NoteOn | NoteOff | KeyPress + deriving Show + +data CtrlEv = Controller | PgmChange | ChanPress + | PitchBend | Control14 + | NonRegParam | RegParam + | SongPos | SongSel + | QFrame + | TimeSign | KeySign + deriving Show + +data EmptyEv = TuneRequest | Reset | Sensing | None | Unknown + deriving Show + +data AddrEv = ClientStart | ClientExit | ClientChange + | PortStart | PortExit | PortChange + deriving Show + +data ConnEv = PortSubscribed | PortUnsubscribed + deriving Show + + +exp_note_ev :: NoteEv -> Word8 +exp_note_ev e = case e of + ANote -> #{const SND_SEQ_EVENT_NOTE} + NoteOn -> #{const SND_SEQ_EVENT_NOTEON} + NoteOff -> #{const SND_SEQ_EVENT_NOTEOFF} + KeyPress -> #{const SND_SEQ_EVENT_KEYPRESS} + +exp_ctrl_ev :: CtrlEv -> Word8 +exp_ctrl_ev e = case e of + Controller -> #{const SND_SEQ_EVENT_CONTROLLER} + PgmChange -> #{const SND_SEQ_EVENT_PGMCHANGE} + ChanPress -> #{const SND_SEQ_EVENT_CHANPRESS} + PitchBend -> #{const SND_SEQ_EVENT_PITCHBEND} + Control14 -> #{const SND_SEQ_EVENT_CONTROL14} + NonRegParam -> #{const SND_SEQ_EVENT_NONREGPARAM} + RegParam -> #{const SND_SEQ_EVENT_REGPARAM} + SongPos -> #{const SND_SEQ_EVENT_SONGPOS} + SongSel -> #{const SND_SEQ_EVENT_SONGSEL} + QFrame -> #{const SND_SEQ_EVENT_QFRAME} + TimeSign -> #{const SND_SEQ_EVENT_TIMESIGN} + KeySign -> #{const SND_SEQ_EVENT_KEYSIGN} + +exp_empty_ev :: EmptyEv -> Word8 +exp_empty_ev e = case e of + TuneRequest -> #{const SND_SEQ_EVENT_TUNE_REQUEST} + Reset -> #{const SND_SEQ_EVENT_RESET} + Sensing -> #{const SND_SEQ_EVENT_SENSING} + None -> #{const SND_SEQ_EVENT_NONE} + Unknown -> #{const SND_SEQ_EVENT_NONE} + +exp_addr_ev :: AddrEv -> Word8 +exp_addr_ev e = case e of + ClientStart -> #{const SND_SEQ_EVENT_CLIENT_START} + ClientExit -> #{const SND_SEQ_EVENT_CLIENT_EXIT} + ClientChange -> #{const SND_SEQ_EVENT_CLIENT_CHANGE} + PortStart -> #{const SND_SEQ_EVENT_PORT_START} + PortExit -> #{const SND_SEQ_EVENT_PORT_EXIT} + PortChange -> #{const SND_SEQ_EVENT_PORT_CHANGE} + +exp_conn_ev :: ConnEv -> Word8 +exp_conn_ev e = case e of + PortSubscribed -> #{const SND_SEQ_EVENT_PORT_SUBSCRIBED} + PortUnsubscribed -> #{const SND_SEQ_EVENT_PORT_UNSUBSCRIBED} + + +peek_note_ev :: NoteEv -> Ptr EventData -> IO EventData +peek_note_ev e p = NoteEv e `fmap` peek (castPtr p) + +peek_ctrl_ev :: CtrlEv -> Ptr EventData -> IO EventData +peek_ctrl_ev e p = CtrlEv e `fmap` peek (castPtr p) + +peek_addr_ev :: AddrEv -> Ptr EventData -> IO EventData +peek_addr_ev e p = AddrEv e `fmap` peek (castPtr p) + +peek_conn_ev :: ConnEv -> Ptr EventData -> IO EventData +peek_conn_ev e p = ConnEv e `fmap` peek (castPtr p) + +peek_empty_ev :: EmptyEv -> Ptr EventData -> IO EventData +peek_empty_ev e _ = return (EmptyEv e) + + +data EventData + = NoteEv NoteEv Note + | CtrlEv CtrlEv Ctrl + | AddrEv AddrEv Addr + | ConnEv ConnEv Connect + | EmptyEv EmptyEv + deriving Show + + diff --git a/Sound/Alsa/Sequencer/Port.hs b/Sound/Alsa/Sequencer/Port.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Port.hs @@ -0,0 +1,216 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Port +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- This module contains functions for working with ports. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Port + ( Port -- :: * + , port_system_timer -- :: Port + , port_system_announce -- :: Port + , port_unknown -- :: Port + + , PortCap -- :: * + , cap_read -- :: PortCap + , cap_write -- :: PortCap + , cap_sync_read -- :: PortCap + , cap_sync_write -- :: PortCap + , cap_duplex -- :: PortCap + , cap_subs_read -- :: PortCap + , cap_subs_write -- :: PortCap + , cap_no_export -- :: PortCap + , caps -- :: [PortCap] -> PortCap + + , PortType -- :: * + , type_specific -- :: PortType + , type_midi_generic -- :: PortType + , type_midi_gm -- :: PortType + , type_midi_gs -- :: PortType + , type_midi_xg -- :: PortType + , type_midi_mt32 -- :: PortType + , type_midi_gm2 -- :: PortType + + , type_synth -- :: PortType + , type_direct_sample -- :: PortType + , type_sample -- :: PortType + + , type_hardware -- :: PortType + , type_software -- :: PortType + , type_synthesizer -- :: PortType + , type_port -- :: PortType + , type_application -- :: PortType + , types -- :: [PortType] -> PortType + + , PortInfo -- :: * + + , create_port -- :: SndSeq -> PortInfo -> IO () + , create_simple_port -- :: SndSeq -> String -> PortCap -> PortType -> IO Port + , delete_port -- :: SndSeq -> Port -> IO () + + , get_port_info -- :: SndSeq -> IO PortInfo + , get_any_port_info -- :: SndSeq -> Client -> Port -> IO PortInfo + , query_first_port -- :: SndSeq -> IO PortInfo + , query_next_port -- :: SndSeq -> PortInfo -> IO () + , set_port_info -- :: SndSeq -> Port -> PortInfo -> IO () + + , port_info_copy -- :: PortInfo -> PortInfo -> IO () + , port_info_clone -- :: PortInfo -> IO PortInfo + + , port_info_get_port -- :: PortInfo -> IO Port + , port_info_get_client -- :: PortInfo -> IO Client + , port_info_get_addr -- :: PortInfo -> IO Addr + , port_info_get_name -- :: PortInfo -> IO String + , port_info_get_capability -- :: PortInfo -> IO PortCap + , port_info_get_midi_channels -- :: PortInfo -> IO Word + , port_info_get_midi_voices -- :: PortInfo -> IO Word + , port_info_get_synth_voices -- :: PortInfo -> IO Word + , port_info_get_port_specified -- :: PortInfo -> IO Bool + , port_info_get_timestamping -- :: PortInfo -> IO Bool + , port_info_get_timestamp_real -- :: PortInfo -> IO Bool + , port_info_get_timestamp_queue -- :: PortInfo -> IO Queue + + , port_info_get_read_use -- :: PortInfo -> IO Word + , port_info_get_write_use -- :: PortInfo -> IO Word + + , port_info_set_port -- :: PortInfo -> Port -> IO () + , port_info_set_client -- :: PortInfo -> Client -> IO () + , port_info_set_addr -- :: PortInfo -> Addr -> IO () + , port_info_set_name -- :: PortInfo -> String -> IO () + , port_info_set_capability -- :: PortInfo -> PortCap -> IO () + , port_info_set_midi_channels -- :: PortInfo -> Word -> IO () + , port_info_set_synth_voices -- :: PortInfo -> Word -> IO () + , port_info_set_midi_voices -- :: PortInfo -> Word -> IO () + , port_info_set_port_specified -- :: PortInfo -> Bool -> IO () + , port_info_set_timestamping -- :: PortInfo -> Bool -> IO () + , port_info_set_timestamp_real -- :: PortInfo -> Bool -> IO () + , port_info_set_timestamp_queue -- :: PortInfo -> Queue -> IO () + ) where + +import Foreign.C.Types(CInt,CUInt) +import Foreign.C.String(CString,withCAString) +import Foreign.Ptr(Ptr) +import Foreign.Marshal.Alloc(alloca) +import Foreign.Storable + +import Sound.Alsa.Sequencer.Marshal +import Sound.Alsa.Sequencer.Area +import Sound.Alsa.Sequencer.Errors + + + + +-------------------------------------------------------------------------------- + +-- | Create a port - simple version. +create_simple_port :: SndSeq -> String -> PortCap -> PortType -> IO Port +create_simple_port (SndSeq h) s (PortCap c) (PortType t) = + withCAString s $ \a -> + imp_Port `fmap` (check_error =<< snd_seq_create_simple_port h a c t) + +foreign import ccall "alsa/asoundlib.h snd_seq_create_simple_port" + snd_seq_create_simple_port :: Ptr SndSeq_ -> CString -> CUInt -> CUInt + -> IO CInt + + + + +-------------------------------------------------------------------------------- + +-- | Create a new port, as described by the info structure. +create_port :: SndSeq -> PortInfo -> IO () +create_port (SndSeq s) p = + check_error_ =<< with_port_info p (snd_seq_create_port s) + +foreign import ccall "alsa/asoundlib.h snd_seq_create_port" + snd_seq_create_port :: Ptr SndSeq_ -> Ptr PortInfo_ -> IO CInt + +-- | Delete the port. +delete_port :: SndSeq -> Port -> IO () +delete_port (SndSeq h) (Port p) = + check_error_ =<< snd_seq_delete_port h (fromIntegral p) + +foreign import ccall "alsa/asoundlib.h snd_seq_delete_port" + snd_seq_delete_port :: Ptr SndSeq_ -> CInt -> IO CInt + +-- | Create a new information area filled with data about a specific +-- port on our client. +get_port_info :: SndSeq -> Port -> IO PortInfo +get_port_info (SndSeq h) p = + do info <- port_info_malloc + check_error =<< with_port_info info (snd_seq_get_port_info h (exp_Port p)) + return info + +foreign import ccall "alsa/asoundlib.h snd_seq_get_port_info" + snd_seq_get_port_info :: Ptr SndSeq_ -> CInt -> Ptr PortInfo_ -> IO CInt + + +-- | Create a new information area filled with data about an given +-- port on a given client. +get_any_port_info :: SndSeq -> Client -> Port -> IO PortInfo +get_any_port_info (SndSeq h) c p = + do info <- port_info_malloc + check_error =<< with_port_info info + (snd_seq_get_any_port_info h (exp_Client c) (exp_Port p)) + return info + +foreign import ccall "alsa/asoundlib.h snd_seq_get_any_port_info" + snd_seq_get_any_port_info + :: Ptr SndSeq_ -> CInt -> CInt -> Ptr PortInfo_ -> IO CInt + +-- | Get information about the first port on our client. +query_first_port :: SndSeq -> IO PortInfo +query_first_port s = + do x <- port_info_malloc + with_port_info x (`snd_seq_port_info_set_port` (-1)) + query_next_port s x + return x + + +-- | Get information about the port with the next biggest identifier. +-- If a matching port is found, then its information is stored in the +-- given area, otherwise we throw an error. +query_next_port :: SndSeq -> PortInfo -> IO () +query_next_port (SndSeq h) info = + check_error_ =<< with_port_info info (snd_seq_query_next_port h) + +foreign import ccall "alsa/asoundlib.h snd_seq_query_next_port" + snd_seq_query_next_port :: Ptr SndSeq_ -> Ptr PortInfo_ -> IO CInt + +-- | Set the information for the sequencer port based on the data +-- in the given information area. +set_port_info :: SndSeq -> Port -> PortInfo -> IO () +set_port_info (SndSeq h) p info = + check_error_ =<< with_port_info info (snd_seq_set_port_info h (exp_Port p)) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_port_info" + snd_seq_set_port_info :: Ptr SndSeq_ -> CInt -> Ptr PortInfo_ -> IO CInt + + + +-- | Get the address of the information area. +port_info_get_addr :: PortInfo -> IO Addr +port_info_get_addr i = + peek =<< with_port_info i snd_seq_port_info_get_addr + +foreign import ccall "alsa/asoundlib.h snd_seq_port_info_get_addr" + snd_seq_port_info_get_addr :: Ptr PortInfo_ -> IO (Ptr Addr) + + +-- | Set the port address. +port_info_set_addr :: PortInfo -> Addr -> IO () +port_info_set_addr i c = + alloca $ \p -> poke p c >> with_port_info i (`snd_seq_port_info_set_addr` p) + +foreign import ccall "alsa/asoundlib.h snd_seq_port_info_set_addr" + snd_seq_port_info_set_addr :: Ptr PortInfo_ -> Ptr Addr -> IO () + + + diff --git a/Sound/Alsa/Sequencer/Queue.hs b/Sound/Alsa/Sequencer/Queue.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Queue.hs @@ -0,0 +1,192 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.Alsa.Sequencer.Queue +-- Copyright : (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Iavor S. Diatchki +-- Stability : provisional +-- +-- This module contains functions for working with sequencer queue. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.Alsa.Sequencer.Queue + ( -- * General Queue Functions + Queue + , queue_direct + , alloc_queue + , alloc_named_queue + , free_queue + + -- * Queue Information + , QueueInfo + , get_queue_info + , set_queue_info + , queue_info_copy + , queue_info_clone + + , queue_info_get_queue + , queue_info_get_name + , queue_info_get_locked + , queue_info_get_owner + , queue_info_get_flags + + , queue_info_set_name + , queue_info_set_locked + , queue_info_set_owner + , queue_info_set_flags + + -- * Queue Status + , QueueStatus + , get_queue_status + , queue_status_copy + , queue_status_clone + + + -- * Queue Tempo + , QueueTempo + , get_queue_tempo + , set_queue_tempo + , queue_tempo_copy + , queue_tempo_clone + + , queue_tempo_get_queue + , queue_tempo_get_tempo + , queue_tempo_get_ppq + , queue_tempo_get_skew + , queue_tempo_get_skew_base + + , queue_tempo_set_tempo + , queue_tempo_set_ppq + , queue_tempo_set_skew + , queue_tempo_set_skew_base + + -- * Queue Timer + , QueueTimer + , get_queue_timer + , set_queue_timer + , queue_timer_copy + , queue_timer_clone + + , queue_timer_get_queue + , queue_timer_get_type + , queue_timer_get_resolution + + , queue_timer_set_type + , queue_timer_set_resolution + + , QueueTimerType(..) + ) where + +import Sound.Alsa.Sequencer.Area +import Sound.Alsa.Sequencer.Marshal +import Sound.Alsa.Sequencer.Errors + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +alloc_queue :: SndSeq -> IO Queue -- ^ Queue identifier. +alloc_queue (SndSeq h) = + imp_Queue `fmap` (check_error =<< snd_seq_alloc_queue h) + +foreign import ccall "alsa/asoundlib.h snd_seq_alloc_queue" + snd_seq_alloc_queue :: Ptr SndSeq_ -> IO CInt + + +alloc_named_queue :: SndSeq -> String -> IO Queue +alloc_named_queue (SndSeq h) x = withCAString x $ \s -> + imp_Queue `fmap` (check_error =<< snd_seq_alloc_named_queue h s) + +foreign import ccall "alsa/asoundlib.h snd_seq_alloc_named_queue" + snd_seq_alloc_named_queue :: Ptr SndSeq_ -> CString -> IO CInt + + +-- | Delete the specified queue. +free_queue + :: SndSeq -- ^ Sequencer handle. + -> Queue -- ^ Queue identifier. + -> IO () +free_queue (SndSeq h) q = + check_error_ =<< snd_seq_free_queue h (exp_Queue q) + +foreign import ccall "alsa/asoundlib.h snd_seq_free_queue" + snd_seq_free_queue :: Ptr SndSeq_ -> CInt -> IO CInt + + +-- XXX: Lots of duplication. + +get_queue_info :: SndSeq -> Queue -> IO QueueInfo +get_queue_info (SndSeq h) q = + do info <- queue_info_malloc + check_error =<< with_queue_info info + (snd_seq_get_queue_info h (exp_Queue q)) + return info + +foreign import ccall "alsa/asoundlib.h snd_seq_get_queue_info" + snd_seq_get_queue_info :: Ptr SndSeq_ -> CInt -> Ptr QueueInfo_ -> IO CInt + + +set_queue_info :: SndSeq -> Queue -> QueueInfo -> IO () +set_queue_info (SndSeq h) p info = + check_error_ =<< with_queue_info info (snd_seq_set_queue_info h (exp_Queue p)) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_queue_info" + snd_seq_set_queue_info :: Ptr SndSeq_ -> CInt -> Ptr QueueInfo_ -> IO CInt + + + +get_queue_tempo :: SndSeq -> Queue -> IO QueueTempo +get_queue_tempo (SndSeq h) q = + do tempo <- queue_tempo_malloc + check_error =<< with_queue_tempo tempo + (snd_seq_get_queue_tempo h (exp_Queue q)) + return tempo + +foreign import ccall "alsa/asoundlib.h snd_seq_get_queue_tempo" + snd_seq_get_queue_tempo :: Ptr SndSeq_ -> CInt -> Ptr QueueTempo_ -> IO CInt + + +set_queue_tempo :: SndSeq -> Queue -> QueueTempo -> IO () +set_queue_tempo (SndSeq h) p tempo = + check_error_ =<< with_queue_tempo tempo (snd_seq_set_queue_tempo h (exp_Queue p)) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_queue_tempo" + snd_seq_set_queue_tempo :: Ptr SndSeq_ -> CInt -> Ptr QueueTempo_ -> IO CInt + + + + + +get_queue_status :: SndSeq -> Queue -> IO QueueStatus +get_queue_status (SndSeq h) q = + do status <- queue_status_malloc + check_error =<< with_queue_status status + (snd_seq_get_queue_status h (exp_Queue q)) + return status + +foreign import ccall "alsa/asoundlib.h snd_seq_get_queue_status" + snd_seq_get_queue_status :: Ptr SndSeq_ -> CInt -> Ptr QueueStatus_ -> IO CInt + + +get_queue_timer :: SndSeq -> Queue -> IO QueueTimer +get_queue_timer (SndSeq h) q = + do timer <- queue_timer_malloc + check_error =<< with_queue_timer timer + (snd_seq_get_queue_timer h (exp_Queue q)) + return timer + +foreign import ccall "alsa/asoundlib.h snd_seq_get_queue_timer" + snd_seq_get_queue_timer :: Ptr SndSeq_ -> CInt -> Ptr QueueTimer_ -> IO CInt + + +set_queue_timer :: SndSeq -> Queue -> QueueTimer -> IO () +set_queue_timer (SndSeq h) p timer = + check_error_ =<< with_queue_timer timer (snd_seq_set_queue_timer h (exp_Queue p)) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_queue_timer" + snd_seq_set_queue_timer :: Ptr SndSeq_ -> CInt -> Ptr QueueTimer_ -> IO CInt + + diff --git a/Sound/Alsa/Sequencer/Sequencer.hs b/Sound/Alsa/Sequencer/Sequencer.hs new file mode 100644 --- /dev/null +++ b/Sound/Alsa/Sequencer/Sequencer.hs @@ -0,0 +1,276 @@ +{-| PRIVATE MODULE +Reference: + +-} + +module Sound.Alsa.Sequencer.Sequencer where + + +import Foreign.C.Types(CInt,CSize) +import Foreign.C.String(CString,withCAString,peekCString) +import Foreign.Ptr(Ptr) +import Foreign.Marshal.Alloc(alloca) +import Foreign.Storable + +import Data.Word + +import Sound.Alsa.Sequencer.Marshal +import Sound.Alsa.Sequencer.Errors + + +-- | Creates a new handle and opens a connection to the kernel sequencer +-- interface. After a client is created successfully, +-- a 'ClientStart' event is broadcast to the announce port. +-- May throw an exception. +-- See also: 'open_lconf', 'close', 'get_seq_type', +-- 'get_seq_name', 'set_blocking', 'get_client_id'. + +open + :: String -- ^ The sequencer's \"name\". This is not a name that you + -- make up for your own purposes; it has special significance + -- to the ALSA library. Usually you need to pass 'default_name' + -- here. + -> OpenMode -- Read\/Write permissions + -> BlockMode -- Blocking behavior + -> IO SndSeq -- Handle to the sequencer. + +open t om bm = alloca $ \p -> withCAString t $ \s -> + do check_error_ =<< snd_seq_open p s (exp_OpenMode om) (exp_BlockMode bm) + SndSeq `fmap` peek p + +foreign import ccall "alsa/asoundlib.h snd_seq_open" + snd_seq_open :: Ptr (Ptr SndSeq_) -> CString -> CInt -> CInt -> IO CInt + + +-- | Close the sequencer. Closes the sequencer client and releases its +-- resources. After a client is closed, an event with 'ClientExit' is +-- broadcast to announce port. The connection between other clients are +-- disconnected. Call this just before exiting your program. +-- NOTE: we could put this in a finalizer for the handle? + +close + :: SndSeq -- ^ handle to the sequencer + -> IO () +close (SndSeq s) = check_error_ =<< snd_seq_close s + +foreign import ccall "alsa/asoundlib.h snd_seq_close" + snd_seq_close :: Ptr SndSeq_ -> IO CInt + + +-- | Get identifier of a sequencer handle. +-- It is the same identifier specified in the call to 'open'. +get_seq_name + :: SndSeq -- ^ sequencer handle + -> IO String -- ^ ALSA identifier for the handel +get_seq_name (SndSeq h) = peekCString =<< snd_seq_name h + +foreign import ccall "alsa/asoundlib.h snd_seq_name" + snd_seq_name :: Ptr SndSeq_ -> IO CString + + +-- | Change the blocking mode of the given client. +-- In block mode, the client falls into sleep when it fills the output +-- pool with events, or when it demands events from an empty input pool. +-- memory pool with full events. Clients that are sleeping due to +-- loack of space in the output pool are woken when a certain +-- amount of free space becomes available (see 'set_output_room'). +set_blocking + :: SndSeq -- ^ sequencer handle + -> BlockMode -- ^ blocking mode + -> IO () +set_blocking (SndSeq h) m = check_error_ =<< snd_seq_nonblock h(exp_BlockMode m) + +foreign import ccall "alsa/asoundlib.h snd_seq_nonblock" + snd_seq_nonblock :: Ptr SndSeq_ -> CInt -> IO CInt + + + +-- Buffers --------------------------------------------------------------------- + +-- | Return the byte size of the output buffer. +get_output_buffer_size + :: SndSeq -- ^ Sequencer handle. + -> IO Word -- ^ Size of output buffer in bytes. + +get_output_buffer_size (SndSeq h) = + fromIntegral `fmap` snd_seq_get_output_buffer_size h + +foreign import ccall "alsa/asoundlib.h snd_seq_get_output_buffer_size" + snd_seq_get_output_buffer_size :: Ptr SndSeq_ -> IO CSize + + +-- | Resize of the output buffer. +-- This function clears all output events (see 'drop_output'). +set_output_buffer_size + :: SndSeq -- ^ Sequencer handle. + -> Word -- ^ New buffer size in bytes. + -> IO () + +set_output_buffer_size (SndSeq h) x = + check_error_ =<< snd_seq_set_output_buffer_size h (fromIntegral x) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_output_buffer_size" + snd_seq_set_output_buffer_size :: Ptr SndSeq_ -> CSize -> IO CInt + + +-- | Return the byte size of input buffer. +get_input_buffer_size + :: SndSeq -- ^ Sequencer handle. + -> IO Word -- ^ Size of input buffer in bytes. + +get_input_buffer_size (SndSeq h) = + fromIntegral `fmap` snd_seq_get_input_buffer_size h + +foreign import ccall "alsa/asoundlib.h snd_seq_get_input_buffer_size" + snd_seq_get_input_buffer_size :: Ptr SndSeq_ -> IO CSize + + +-- | Resize the input buffer. +-- This function clears all input events (see 'drop_input'). +set_input_buffer_size + :: SndSeq -- ^ Sequencer handle. + -> Word -- ^ New byffer size in bytes. + -> IO () + +set_input_buffer_size (SndSeq h) x = + check_error_ =<< snd_seq_set_input_buffer_size h (fromIntegral x) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_input_buffer_size" + snd_seq_set_input_buffer_size :: Ptr SndSeq_ -> CSize -> IO CInt + + + +-- Pool management ------------------------------------------------------------- + +-- | Resize the output memory pool. +set_pool_output + :: SndSeq -- ^ Sequencer handle. + -> Word -- ^ New size in bytes. + -> IO () + +set_pool_output (SndSeq h) x = + check_error_ =<< snd_seq_set_client_pool_output h (fromIntegral x) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_client_pool_output" + snd_seq_set_client_pool_output :: Ptr SndSeq_ -> CSize -> IO CInt + + +-- | Specify how much space should become free before waking clients +-- that are blocked due to a lack of space in the output pool. +set_pool_output_room + :: SndSeq -- ^ Sequencer handle. + -> Word -- ^ Number of bytes need to wake up. + -> IO () + +set_pool_output_room (SndSeq h) x = + check_error_ =<< snd_seq_set_client_pool_output_room h (fromIntegral x) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_client_pool_output_room" + snd_seq_set_client_pool_output_room :: Ptr SndSeq_ -> CSize -> IO CInt + + +-- | Reset the output pool. +reset_pool_output + :: SndSeq -- ^ Sequencer handle. + -> IO () + +reset_pool_output (SndSeq h) = + check_error_ =<< snd_seq_reset_pool_output h + +foreign import ccall "alsa/asoundlib.h snd_seq_reset_pool_output" + snd_seq_reset_pool_output :: Ptr SndSeq_ -> IO CInt + + + +-- | Resize the input memory pool. +set_pool_input + :: SndSeq -- ^ Sequencer handle. + -> Word -- ^ New size in bytes. + -> IO () + +set_pool_input (SndSeq h) x = + check_error_ =<< snd_seq_set_client_pool_input h (fromIntegral x) + +foreign import ccall "alsa/asoundlib.h snd_seq_set_client_pool_input" + snd_seq_set_client_pool_input :: Ptr SndSeq_ -> CSize -> IO CInt + + +-- | Reset the input pool. +reset_pool_input + :: SndSeq -- ^ Sequencer handle. + -> IO () + +reset_pool_input (SndSeq h) = + check_error_ =<< snd_seq_reset_pool_input h + +foreign import ccall "alsa/asoundlib.h snd_seq_reset_pool_input" + snd_seq_reset_pool_input :: Ptr SndSeq_ -> IO CInt + + + + + + + + + +--Middle Level Interface ------------------------------------------------------- + + +-- | Simple subscription (w\/o exclusive & time conversion). +connect_from :: SndSeq -> Port -> Addr -> IO () +connect_from (SndSeq h) me a = + check_error_ =<< snd_seq_connect_from h (exp_Port me) c p + where (c,p) = exp_Addr a + +foreign import ccall "alsa/asoundlib.h snd_seq_connect_from" + snd_seq_connect_from :: Ptr SndSeq_ -> CInt -> CInt -> CInt -> IO CInt + + +-- | Simple subscription (w\/o exclusive & time conversion). +connect_to :: SndSeq -> Port -> Addr -> IO () +connect_to (SndSeq h) me a = + check_error_ =<< snd_seq_connect_to h (exp_Port me) c p + where (c,p) = exp_Addr a + +foreign import ccall "alsa/asoundlib.h snd_seq_connect_to" + snd_seq_connect_to :: Ptr SndSeq_ -> CInt -> CInt -> CInt -> IO CInt + + +-- | Simple disconnection. +disconnect_from :: SndSeq -> Port -> Addr -> IO () +disconnect_from (SndSeq h) me a = + check_error_ =<< snd_seq_disconnect_from h (exp_Port me) c p + where (c,p) = exp_Addr a + +foreign import ccall "alsa/asoundlib.h snd_seq_disconnect_from" + snd_seq_disconnect_from :: Ptr SndSeq_ -> CInt -> CInt -> CInt -> IO CInt + +-- | Simple disconnection. +disconnect_to :: SndSeq -> Port -> Addr -> IO () +disconnect_to (SndSeq h) me a = + check_error_ =<< snd_seq_disconnect_to h (exp_Port me) c p + where (c,p) = exp_Addr a + +foreign import ccall "alsa/asoundlib.h snd_seq_disconnect_to" + snd_seq_disconnect_to :: Ptr SndSeq_ -> CInt -> CInt -> CInt -> IO CInt + + +-- | Parse the given string into sequencer address. +-- The client and port are separated by either colon or period, e.g. 128:1. +-- The function also accepts client names. +parse_address + :: SndSeq -- ^ Sequencer handle. + -> String -- ^ String to be parsed. + -> IO Addr -- ^ The parsed address. + +parse_address (SndSeq h) s = + alloca $ \pa -> + withCAString s $ \ps -> + do check_error =<< snd_seq_parse_address h pa ps + peek pa + +foreign import ccall "alsa/asoundlib.h snd_seq_parse_address" + snd_seq_parse_address :: Ptr SndSeq_ -> Ptr Addr -> CString -> IO CInt + + diff --git a/alsa.cabal b/alsa.cabal new file mode 100644 --- /dev/null +++ b/alsa.cabal @@ -0,0 +1,50 @@ +Name: alsa +Version: 0.2 +Copyright: Bjorn Bringert, Iavor S. Diatchki +Maintainer: bjorn@bringert.net, iavor.diatchki@gmail.com +Author: Bjorn Bringert, Iavor S. Diatchki +Category: Sound, Music +License: BSD3 +License-file: LICENSE +Build-depends: + base >= 3, + array >= 0.1 && <0.3 +Stability: Experimental +Extensions: ForeignFunctionInterface, GeneralizedNewtypeDeriving, EmptyDataDecls +Build-Type: Simple + +Synopsis: Binding to the ALSA Library API. +Description: + This package provides access to + . + * ALSA sequencer (MIDI support) + . + * ALSA realtime audio signal input and output + +Ghc-options: -Wall +Exposed-Modules: + Sound.Alsa + Sound.Alsa.Core + Sound.Alsa.Error + Sound.Alsa.Sequencer + Sound.Alsa.Sequencer.Client + Sound.Alsa.Sequencer.Port + Sound.Alsa.Sequencer.Event + Sound.Alsa.Sequencer.Queue + +Other-modules: + Sound.Alsa.C2HS + Sound.Alsa.Sequencer.Marshal + Sound.Alsa.Sequencer.Area + Sound.Alsa.Sequencer.Errors + Sound.Alsa.Sequencer.Sequencer + +Extra-Source-Files: + examples/duplex.hs + examples/play.hs + examples/record.hs + examples/volume_meter.hs + examples/Makefile + +Includes: alsa/asoundlib.h +Extra-libraries: asound diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,19 @@ +.PHONY: all clean + +all: volume_meter record play duplex + +volume_meter: volume_meter.hs + ghc -threaded --make -package alsa -o $@ $< + +record: record.hs + ghc -threaded --make -package alsa -o $@ $< + +play: play.hs + ghc -threaded --make -package alsa -o $@ $< + +duplex: duplex.hs + ghc -threaded --make -package alsa -o $@ $< + +clean: + -rm -f *o *.hi + -rm -f volume_meter record play duplex diff --git a/examples/duplex.hs b/examples/duplex.hs new file mode 100644 --- /dev/null +++ b/examples/duplex.hs @@ -0,0 +1,44 @@ +import Sound.Alsa + +import Control.Concurrent +import System.Environment +import System.Exit +import System.IO + +bufSize :: Int +bufSize = 4096 + +soundFormat :: SoundFmt +soundFormat = SoundFmt { + sampleFmt = SampleFmtLinear16BitSignedLE, + sampleFreq = 8000, + numChannels = 1 + } + +main :: IO () +main = do args <- getArgs + case args of + [infile,outfile] -> duplex infile outfile + _ -> + do hPutStrLn stderr "Usage: duplex " + exitFailure + +duplex :: FilePath -> FilePath -> IO () +duplex infile outfile = + do forkOS (play infile) + forkOS (record outfile) + threadDelay 5000000 + return () + + +play :: FilePath -> IO () +play file = + do let source = fileSoundSource file soundFormat + sink = alsaSoundSink "plughw:0,0" soundFormat + copySound source sink bufSize + +record :: FilePath -> IO () +record file = + do let source = alsaSoundSource "plughw:0,0" soundFormat + sink = fileSoundSink file soundFormat + copySound source sink bufSize diff --git a/examples/play.hs b/examples/play.hs new file mode 100644 --- /dev/null +++ b/examples/play.hs @@ -0,0 +1,28 @@ +import Sound.Alsa + +import System.Environment +import System.Exit +import System.IO + +bufSize :: Int +bufSize = 8192 + +soundFormat :: SoundFmt +soundFormat = SoundFmt { + sampleFmt = SampleFmtLinear16BitSignedLE, + sampleFreq = 8000, + numChannels = 1 + } + +main :: IO () +main = do args <- getArgs + case args of + [file] -> play file + _ -> do hPutStrLn stderr "Usage: play " + exitFailure + +play :: FilePath -> IO () +play file = + do let source = fileSoundSource file soundFormat + sink = alsaSoundSink "plughw:0,0" soundFormat + copySound source sink bufSize diff --git a/examples/record.hs b/examples/record.hs new file mode 100644 --- /dev/null +++ b/examples/record.hs @@ -0,0 +1,28 @@ +import Sound.Alsa + +import System.Environment +import System.Exit +import System.IO + +bufSize :: Int +bufSize = 8192 + +soundFormat :: SoundFmt +soundFormat = SoundFmt { + sampleFmt = SampleFmtLinear16BitSignedLE, + sampleFreq = 8000, + numChannels = 1 + } + +main :: IO () +main = do args <- getArgs + case args of + [file] -> record file + _ -> do hPutStrLn stderr "Usage: record " + exitFailure + +record :: FilePath -> IO () +record file = + do let source = alsaSoundSource "plughw:0,0" soundFormat + sink = fileSoundSink file soundFormat + copySound source sink bufSize diff --git a/examples/volume_meter.hs b/examples/volume_meter.hs new file mode 100644 --- /dev/null +++ b/examples/volume_meter.hs @@ -0,0 +1,34 @@ +import Sound.Alsa + +import Foreign +import Data.Word + +bufSize :: Int +bufSize = 1000 + +inputFormat :: SoundFmt +inputFormat = SoundFmt { + sampleFmt = SampleFmtLinear16BitSignedLE, + sampleFreq = 8000, + numChannels = 1 + } + + +main :: IO () +main = let source = alsaSoundSource "plughw:0,0" inputFormat + in allocaArray bufSize $ \buf -> + withSoundSource source $ \from -> + loop source from bufSize buf + +-- FIXME: assumes little-endian machine +loop :: SoundSource h -> h -> Int -> Ptr Int16 -> IO () +loop src h n buf = + do n' <- soundSourceRead src h (castPtr buf) n + avg <- avgBuf buf n' + putStrLn (replicate (avg `div` 20) '*') + loop src h n buf + +avgBuf :: (Storable a, Integral a) => Ptr a -> Int -> IO Int +avgBuf buf n = do xs <- peekArray n buf + let xs' = map (fromIntegral . abs) xs :: [Int] + return $ sum xs' `div` fromIntegral n