New patches: [unrevert anon**20111218225547 Ignore-this: 2a5ee6eb604487a364faf98499b4e336 ] { hunk ./src/Sound/ALSA/PCM.hs 1 -{-# LANGUAGE ForeignFunctionInterface #-} -module Sound.ALSA.PCM - (SampleFmt(..), - SampleFreq, - Time, - SoundFmt(..), - SoundSource(..), - SoundSink(..), - SoundBufferTime(..), - Pcm, - withSoundSource, - withSoundSourceRunning, - withSoundSink, - withSoundSinkRunning, - soundFmtMIME, - audioBytesPerSample, - audioBytesPerFrame, - soundSourceBytesPerFrame, - soundSinkBytesPerFrame, - copySound, - alsaSoundSource, - alsaSoundSink, - alsaSoundSourceTime, - alsaSoundSinkTime, - fileSoundSource, - fileSoundSink, - ) where - -import Sound.ALSA.PCM.Core -import qualified Sound.ALSA.Exception as AlsaExc -import qualified Sound.ALSA.PCM.Debug as Debug - -import qualified Sound.Frame as Frame -import qualified Sound.Frame.Stereo as Stereo -import qualified Sound.Frame.MuLaw as MuLaw - -import Data.Word (Word8, Word16, Word32, ) -import Data.Int (Int8, Int16, Int32, ) - -import Control.Exception (bracket, bracket_, ) -import Control.Monad (liftM, when, ) -import Foreign.Marshal.Array (advancePtr, allocaArray, ) -import Foreign.C (CSize, CInt, ) -import Foreign (Storable, Ptr, minusPtr, ) -import qualified System.IO as IO -import System.IO - (IOMode(ReadMode, WriteMode), Handle, openBinaryFile, hClose, ) - --- --- * Generic sound API --- - -class (Storable y, Frame.C y) => SampleFmt y where - sampleFmtToPcmFormat :: y -> PcmFormat - -type SampleFreq = Int - -data SoundFmt y = SoundFmt { - sampleFreq :: SampleFreq - } - deriving (Show) - -type Time = Int - -data SoundBufferTime = SoundBufferTime { - bufferTime, periodTime :: Time - } - deriving (Show) - - --- | Counts are in samples, not bytes. Multi-channel data is interleaved. -data SoundSource y handle = - SoundSource { - soundSourceFmt :: SoundFmt y, - soundSourceOpen :: IO handle, - soundSourceClose :: handle -> IO (), - soundSourceStart :: handle -> IO (), - soundSourceStop :: handle -> IO (), - soundSourceRead :: handle -> Ptr y -> Int -> IO Int - } - -data SoundSink y handle = - SoundSink { - soundSinkFmt :: SoundFmt y, - soundSinkOpen :: IO handle, - soundSinkClose :: handle -> IO (), - soundSinkWrite :: handle -> Ptr y -> Int -> IO (), - soundSinkStart :: handle -> IO (), - soundSinkStop :: handle -> IO () - } - --- --- --- - -defaultBufferTime :: SoundBufferTime -defaultBufferTime = - SoundBufferTime { - bufferTime = 500000, -- 0.5s - periodTime = 100000 -- 0.1s - } - -nullSoundSource :: SoundFmt y -> SoundSource y h -nullSoundSource fmt = - SoundSource { - soundSourceFmt = fmt, - soundSourceOpen = return undefined, - soundSourceClose = \_ -> return (), - soundSourceStart = \_ -> return (), - soundSourceStop = \_ -> return (), - soundSourceRead = \_ _ _ -> return 0 - } - -nullSoundSink :: SoundFmt y -> SoundSink y h -nullSoundSink fmt = - SoundSink { - soundSinkFmt = fmt, - soundSinkOpen = return undefined, - soundSinkClose = \_ -> return (), - soundSinkStart = \_ -> return (), - soundSinkStop = \_ -> return (), - soundSinkWrite = \_ _ _ -> return () - } - - -withSoundSource :: SoundSource y h -> (h -> IO a) -> IO a -withSoundSource source = - bracket (soundSourceOpen source) (soundSourceClose source) - -withSoundSourceRunning :: SoundSource y h -> h -> IO a -> IO a -withSoundSourceRunning src h = bracket_ (soundSourceStart src h) (soundSourceStop src h) - -withSoundSink :: SoundSink y h -> (h -> IO a) -> IO a -withSoundSink sink = - bracket (soundSinkOpen sink) (soundSinkClose sink) - -withSoundSinkRunning :: SoundSink y h -> h -> IO a -> IO a -withSoundSinkRunning src h = bracket_ (soundSinkStart src h) (soundSinkStop src h) - - -instance SampleFmt Word8 where - sampleFmtToPcmFormat _ = PcmFormatU8 - -instance SampleFmt Int8 where - sampleFmtToPcmFormat _ = PcmFormatS8 - -instance SampleFmt Word16 where - sampleFmtToPcmFormat _ = PcmFormatU16 - -instance SampleFmt Int16 where - sampleFmtToPcmFormat _ = PcmFormatS16 - -instance SampleFmt Word32 where - sampleFmtToPcmFormat _ = PcmFormatU32 - -instance SampleFmt Int32 where - sampleFmtToPcmFormat _ = PcmFormatS32 - -instance SampleFmt Float where - sampleFmtToPcmFormat _ = PcmFormatFloat - -instance SampleFmt Double where - sampleFmtToPcmFormat _ = PcmFormatFloat64 - -instance SampleFmt MuLaw.T where - sampleFmtToPcmFormat _ = PcmFormatMuLaw - -instance SampleFmt a => SampleFmt (Stereo.T a) where - sampleFmtToPcmFormat y = - sampleFmtToPcmFormat (Stereo.left y) - -withSampleFmt :: (y -> a) -> (SoundFmt y -> a) -withSampleFmt f _ = f undefined - - -soundFmtMIME :: SampleFmt y => SoundFmt y -> String -soundFmtMIME fmt = t ++ r ++ c - where t = "audio/basic" -{- - 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) - -numChannels :: SampleFmt y => SoundFmt y -> Int -numChannels = withSampleFmt Frame.numberOfChannels - -audioBytesPerSample :: SampleFmt y => SoundFmt y -> Int -audioBytesPerSample = withSampleFmt Frame.sizeOfElement - -{- -assumes interleaved data - -Due to alignment constraints -a frame might occupy more than the calculated size -in an array in memory. --} -audioBytesPerFrame :: SampleFmt y => SoundFmt y -> Int -audioBytesPerFrame fmt = numChannels fmt * audioBytesPerSample fmt - -soundSourceBytesPerFrame :: SampleFmt y => SoundSource y h -> Int -soundSourceBytesPerFrame = audioBytesPerFrame . soundSourceFmt - -soundSinkBytesPerFrame :: SampleFmt y => SoundSink y h -> Int -soundSinkBytesPerFrame = audioBytesPerFrame . soundSinkFmt - -copySound :: SampleFmt y => - SoundSource y h1 - -> SoundSink y h2 - -> Int -- ^ Buffer size (in sample frames) to use - -> IO () -copySound source sink bufSize = - allocaArray bufSize $ \buf -> - withSoundSource source $ \from -> - withSoundSink sink $ \to -> - let loop = do n <- soundSourceRead source from buf bufSize - when (n > 0) $ do soundSinkWrite sink to buf n - loop - in loop - --- --- * Alsa stuff --- - - -alsaOpen :: SampleFmt y => - String -- ^ device, e.g @"default"@ - -> SoundFmt y - -> SoundBufferTime - -> PcmStream - -> IO Pcm -alsaOpen dev fmt time stream = AlsaExc.rethrow $ - do Debug.put "alsaOpen" - h <- pcm_open dev stream 0 - Debug.put $ "requested buffer_time = " ++ show (bufferTime time) - Debug.put $ "requested period_time = " ++ show (periodTime time) - (buffer_time,buffer_size,period_time,period_size) <- - setHwParams h (withSampleFmt sampleFmtToPcmFormat fmt) - (numChannels fmt) - (sampleFreq fmt) - (bufferTime time) - (periodTime time) - setSwParams h buffer_size period_size - pcm_prepare h - Debug.put $ "buffer_time = " ++ show buffer_time - Debug.put $ "buffer_size = " ++ show buffer_size - Debug.put $ "period_time = " ++ show period_time - Debug.put $ "period_size = " ++ show period_size - when (stream == PcmStreamPlayback) $ - callocaArray fmt period_size $ \buf -> - pcm_writei h buf period_size >> return () - return h - - -setHwParams :: Pcm - -> PcmFormat - -> Int -- ^ number of channels - -> SampleFreq -- ^ sample frequency - -> Time -- ^ buffer time - -> Time -- ^ 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 - (actual_buffer_time,_) <- - pcm_hw_params_set_buffer_time_near h p buffer_time EQ - buffer_size <- pcm_hw_params_get_buffer_size p - (actual_period_time,_) <- - pcm_hw_params_set_period_time_near h p period_time EQ - (period_size,_) <- pcm_hw_params_get_period_size p - return (actual_buffer_time,buffer_size, - actual_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 = - bracket pcm_hw_params_malloc pcm_hw_params_free $ \p -> - do pcm_hw_params_any h p - x <- f p - pcm_hw_params h p - return x - -withSwParams :: Pcm -> (PcmSwParams -> IO a) -> IO a -withSwParams h f = - bracket pcm_sw_params_malloc pcm_sw_params_free $ \p -> - do pcm_sw_params_current h p - x <- f p - pcm_sw_params h p - return x - -alsaClose :: Pcm -> IO () -alsaClose pcm = AlsaExc.rethrow $ - do Debug.put "alsaClose" - pcm_drain pcm - pcm_close pcm - -alsaStart :: Pcm -> IO () -alsaStart pcm = AlsaExc.rethrow $ - do Debug.put "alsaStart" - pcm_prepare pcm - pcm_start pcm - - --- FIXME: use pcm_drain for sinks? -alsaStop :: Pcm -> IO () -alsaStop pcm = AlsaExc.rethrow $ - do Debug.put "alsaStop" - pcm_drain pcm - -alsaRead :: - SampleFmt y => - Pcm -> Ptr y -> Int -> IO Int -alsaRead h buf0 n = - let go buf offset = do - -- debug $ "Reading " ++ show n ++ " samples..." - nread <- - pcm_readi h buf (n-offset) - `AlsaExc.catchXRun` - do Debug.put "snd_pcm_readi reported buffer over-run" - pcm_prepare h - go buf offset - let newOffset = offset+nread - -- debug $ "Got " ++ show n' ++ " samples." - if newOffset < n - then go (advancePtr buf nread) newOffset - else return newOffset - in AlsaExc.rethrow $ go buf0 0 - - -alsaWrite :: - SampleFmt y => - Pcm -> Ptr y -> Int -> IO () -alsaWrite h buf n = AlsaExc.rethrow $ - alsaWrite_ h buf n >> return () - -alsaWrite_ :: - SampleFmt y => - Pcm -> Ptr y -> Int -> IO Int -alsaWrite_ h buf0 n = - let go buf offset = do - --debug $ "Writing " ++ show n ++ " samples..." - nwritten <- - pcm_writei h buf n - `AlsaExc.catchXRun` - do Debug.put "snd_pcm_writei reported buffer under-run" - pcm_prepare h - go buf offset - let newOffset = offset+nwritten - --debug $ "Wrote " ++ show n' ++ " samples." - if newOffset < n - then go (advancePtr buf nwritten) newOffset - else return newOffset - in AlsaExc.rethrow $ go buf0 0 - - -alsaSoundSource :: - SampleFmt y => - String -> SoundFmt y -> SoundSource y Pcm -alsaSoundSource dev fmt = - alsaSoundSourceTime dev fmt defaultBufferTime - -alsaSoundSink :: - SampleFmt y => - String -> SoundFmt y -> SoundSink y Pcm -alsaSoundSink dev fmt = - alsaSoundSinkTime dev fmt defaultBufferTime - -alsaSoundSourceTime :: - SampleFmt y => - String -> SoundFmt y -> SoundBufferTime -> SoundSource y Pcm -alsaSoundSourceTime dev fmt time = - (nullSoundSource fmt) { - soundSourceOpen = alsaOpen dev fmt time PcmStreamCapture, - soundSourceClose = alsaClose, - soundSourceStart = alsaStart, - soundSourceStop = alsaStop, - soundSourceRead = alsaRead - } - -alsaSoundSinkTime :: - SampleFmt y => - String -> SoundFmt y -> SoundBufferTime -> SoundSink y Pcm -alsaSoundSinkTime dev fmt time = - (nullSoundSink fmt) { - soundSinkOpen = alsaOpen dev fmt time PcmStreamPlayback, - soundSinkClose = alsaClose, - soundSinkStart = alsaStart, - soundSinkStop = alsaStop, - soundSinkWrite = alsaWrite - } - --- --- * File stuff --- - -{- | -This expects pad bytes that are needed in memory -in order to satisfy aligment constraints. -This is only a problem for samples sizes like 24 bit. --} -fileRead :: - SampleFmt y => - Handle -> Ptr y -> Int -> IO Int -fileRead h buf n = - liftM (`div` arraySize buf 1) $ - IO.hGetBuf h buf (arraySize buf n) - -{- | -Same restrictions as for 'fileRead'. --} -fileWrite :: - SampleFmt y => - Handle -> Ptr y -> Int -> IO () -fileWrite h buf n = - IO.hPutBuf h buf (arraySize buf n) - -fileSoundSource :: - SampleFmt y => - FilePath -> SoundFmt y -> SoundSource y Handle -fileSoundSource file fmt = - (nullSoundSource fmt) { - soundSourceOpen = openBinaryFile file ReadMode, - soundSourceClose = hClose, - soundSourceRead = fileRead - } - -fileSoundSink :: - SampleFmt y => - FilePath -> SoundFmt y -> SoundSink y Handle -fileSoundSink file fmt = - (nullSoundSink fmt) { - soundSinkOpen = openBinaryFile file WriteMode, - soundSinkClose = hClose, - soundSinkWrite = fileWrite - } - --- --- * Marshalling utilities --- - -callocaArray :: Storable y => SoundFmt y -> Int -> (Ptr y -> IO b) -> IO b -callocaArray _ n f = - allocaArray n $ \p -> - clearBytes p (arraySize p n) >> - f p - -clearBytes :: Ptr a -> Int -> IO () -clearBytes p n = memset p 0 (fromIntegral n) >> return () - -{-# INLINE arraySize #-} -arraySize :: Storable y => Ptr y -> Int -> Int -arraySize p n = advancePtr p n `minusPtr` p - -foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) rmfile ./src/Sound/ALSA/PCM.hs hunk ./src/Sound/ALSA/PCM/C2HS.hs 1 --- 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.PCM.C2HS ( - - -- * Re-export the language-independent component of the FFI - St.Storable, St.poke, St.peek, St.sizeOf, St.alignment, - Ptr, castPtr, with, - Alloc.alloca, - - -- * Re-export the C language component of the FFI - C.CInt, C.CUInt, C.CLong, C.CULong, C.CChar, C.withCString, - - -- * 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.Ptr (Ptr, nullPtr, castPtr, ) -import Foreign.Storable (Storable, peek, ) -import Foreign.Marshal.Utils (fromBool, toBool, with, ) - -import qualified Foreign.Storable as St -import qualified Foreign.Marshal.Alloc as Alloc -import qualified Foreign.C as C - -import Data.Bits (Bits, (.|.), (.&.), ) - -import Control.Monad (liftM, ) - - --- Composite marshalling functions --- ------------------------------- - --- Strings with explicit length --- -withCStringLenIntConv :: - (Integral i) => - String -> ((Ptr C.CChar, i) -> IO a) -> IO a -withCStringLenIntConv s f = - C.withCStringLen s $ \(p, n) -> f (p, cIntConv n) - -peekCStringLenIntConv :: - (Integral i) => - (Ptr C.CChar, i) -> IO String -peekCStringLenIntConv (s, n) = - C.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 rmfile ./src/Sound/ALSA/PCM/C2HS.hs hunk ./src/Sound/ALSA/PCM/Core.chs 1 -{-# LANGUAGE ForeignFunctionInterface #-} -module Sound.ALSA.PCM.Core where - -import Sound.ALSA.PCM.C2HS -import Sound.ALSA.Exception (checkResult, checkResult_, ) - - - --- 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) rmfile ./src/Sound/ALSA/PCM/Core.chs rmdir ./src/Sound/ALSA/PCM rmdir ./src/Sound/ALSA rmdir ./src/Sound rmdir ./src hunk ./nodebug/Sound/ALSA/PCM/Debug.hs 1 -module Sound.ALSA.PCM.Debug where - -put :: String -> IO () -put _ = return () rmfile ./nodebug/Sound/ALSA/PCM/Debug.hs rmdir ./nodebug/Sound/ALSA/PCM rmdir ./nodebug/Sound/ALSA rmdir ./nodebug/Sound rmdir ./nodebug hunk ./examples/LICENSE 1 -Copyright (c) 2010 Henning Thielemann -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. rmfile ./examples/LICENSE hunk ./examples/duplex.hs 1 -import Sound.ALSA.PCM - (SoundFmt(SoundFmt), copySound, sampleFreq, - fileSoundSink, fileSoundSource, - alsaSoundSink, alsaSoundSource, ) - -import Control.Concurrent (forkOS, threadDelay, ) -import System.Environment (getArgs, ) -import System.Exit (exitFailure, ) -import System.IO (hPutStrLn, stderr, ) -import Data.Int (Int16, ) - -bufSize :: Int -bufSize = 4096 - -soundFormat :: SoundFmt Int16 -soundFormat = SoundFmt { sampleFreq = 8000 } - -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 - - -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 rmfile ./examples/duplex.hs hunk ./examples/play.hs 1 -import Sound.ALSA.PCM - (SoundFmt(SoundFmt), copySound, sampleFreq, - fileSoundSource, alsaSoundSink, ) - -import System.Environment (getArgs, ) - -import Data.Int (Int16, ) - -bufSize :: Int -bufSize = 8192 - -soundFormat :: SoundFmt Int16 -soundFormat = SoundFmt { sampleFreq = 8000 } - -main :: IO () -main = - mapM_ play =<< getArgs - -play :: FilePath -> IO () -play file = - copySound - (fileSoundSource file soundFormat) - -- "default" allows mixing with other ALSA programs - (alsaSoundSink "default" soundFormat) - bufSize rmfile ./examples/play.hs hunk ./examples/record.hs 1 -import Sound.ALSA.PCM - (SoundFmt(SoundFmt), copySound, sampleFreq, - fileSoundSink, alsaSoundSource, ) - -import System.Environment (getArgs, ) -import System.Exit (exitFailure, ) -import System.IO (hPutStrLn, stderr, ) -import Data.Int (Int16, ) - -bufSize :: Int -bufSize = 8192 - -soundFormat :: SoundFmt Int16 -soundFormat = SoundFmt { sampleFreq = 8000 } - -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 rmfile ./examples/record.hs hunk ./examples/synth.hs 1 -import qualified Sound.ALSA.PCM as PCM - -import qualified Sound.ALSA.PCM.Core as Core -import qualified Sound.ALSA.Exception as AlsaExc -import qualified Sound.ALSA.PCM.Debug as Debug - -import qualified Sound.ALSA.Sequencer.Address as Addr -import qualified Sound.ALSA.Sequencer.Client as Client -import qualified Sound.ALSA.Sequencer.Port as Port -import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.ALSA.Sequencer.Queue as Queue -import qualified Sound.ALSA.Sequencer.RealTime as RealTime -import qualified Sound.ALSA.Sequencer as SndSeq --- import qualified Sound.ALSA.Exception as AlsaExc - -import qualified Data.StorableVector.ST.Strict as SVST -import qualified Data.StorableVector as SV -import qualified Data.StorableVector.Base as SVB - -import Foreign.Storable (Storable, ) -import Control.Monad.ST.Strict as ST - -import qualified Control.Monad.Trans.State.Strict as MS -import Control.Monad.IO.Class (liftIO, ) - -import qualified Data.Map as Map - -import Data.Word (Word8, ) - -import Control.Exception (bracket, ) -import Control.Monad (liftM, forever, ) - -import Debug.Trace (trace, ) - - -soundFormat :: PCM.SoundFmt Float -soundFormat = PCM.SoundFmt { PCM.sampleFreq = 44100 } - -openPCM :: IO (Int, Int, Core.Pcm) -openPCM = do - Debug.put "alsaOpenTest" - h <- Core.pcm_open "default" Core.PcmStreamPlayback 0 - (bufferTime,bufferSize,periodTime,periodSize,sampleRate) <- - setHwParams h - (PCM.withSampleFmt PCM.sampleFmtToPcmFormat soundFormat) - (PCM.numChannels soundFormat) - (PCM.sampleFreq soundFormat) - 1024 64 - PCM.setSwParams h bufferSize periodSize - Core.pcm_prepare h - Debug.put $ "bufferTime = " ++ show bufferTime - Debug.put $ "bufferSize = " ++ show bufferSize - Debug.put $ "periodTime = " ++ show periodTime - Debug.put $ "periodSize = " ++ show periodSize - return (periodSize, sampleRate, h) - -closePCM :: (Int, Int, Core.Pcm) -> IO () -closePCM (_,_,pcm) = AlsaExc.rethrow $ do - Debug.put "alsaClose" - Core.pcm_drain pcm - Core.pcm_close pcm - -setHwParams :: - Core.Pcm - -> Core.PcmFormat - -> Int -- ^ number of channels - -> PCM.SampleFreq -- ^ sample frequency - -> Int -- ^ buffer size - -> Int -- ^ period size - -> IO (Int,Int,Int,Int,Int) - -- ^ (bufferTime,bufferSize,periodTime,periodSize) -setHwParams h format channels rate bufferSize periodSize = - PCM.withHwParams h $ \p -> do - Core.pcm_hw_params_set_access h p Core.PcmAccessRwInterleaved - Core.pcm_hw_params_set_format h p format - Core.pcm_hw_params_set_channels h p channels -{- - (actualRate,ord) <- - Core.pcm_hw_params_get_rate_max p - print ord --} - Core.pcm_hw_params_set_rate_resample h p False - (actualRate,_) <- - Core.pcm_hw_params_set_rate_near h p rate EQ - (actualPeriodSize,_) <- - Core.pcm_hw_params_set_period_size_near h p periodSize EQ - actualBufferSize <- - Core.pcm_hw_params_set_buffer_size_near h p - (max bufferSize (actualPeriodSize*2)) -{- - let actualBufferSize = bufferSize - Core.pcm_hw_params_set_buffer_size h p bufferSize --} - (actualBufferTime,_) <- Core.pcm_hw_params_get_buffer_time p - (actualPeriodTime,_) <- Core.pcm_hw_params_get_period_time p - return (actualBufferTime, actualBufferSize, - actualPeriodTime, actualPeriodSize, - actualRate) - - -setTimestamping :: - SndSeq.T mode -> Port.T -> Queue.T -> IO () -setTimestamping h p q = do - info <- PortInfo.get h p - PortInfo.setTimestamping info True - PortInfo.setTimestampReal info True - PortInfo.setTimestampQueue info q - PortInfo.set h p info - - -withInPort :: - SndSeq.BlockMode -> - (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t -withInPort blockMode act = - SndSeq.with SndSeq.defaultName blockMode $ \h -> - Client.setName h "alsa-haskell-minisynth" >> - Port.withSimple h "input" - (Port.caps [Port.capWrite, Port.capSubsWrite]) - Port.typeApplication - (act h) - - -type StampedEvent = (Time, Event.T) - -type Time = Integer - - -{- | -RealTime.toFractional for NumericPrelude. --} -realTimeToField :: (Fractional a) => RealTime.T -> a -realTimeToField (RealTime.Cons s n) = - fromIntegral s + fromIntegral n / (10^(9::Int)) - -addStamp :: - Time -> Event.T -> StampedEvent -addStamp rate ev = - (case Event.timestamp ev of - Event.RealTime t -> - div (RealTime.toInteger t * rate) nano - _ -> error "unsupported time stamp type", - ev) - - -nano :: Integer -nano = 10^(9::Int) - -{- | only use it for blocking sequencers -} -getStampedEventsUntilTime :: - (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => - SndSeq.T mode -> - Queue.T -> Port.T -> - Time -> Time -> - IO [StampedEvent] -getStampedEventsUntilTime h q p r t = - fmap (map (addStamp r)) $ getEventsUntilTime h q p r t - - -{- | -Get events until a certain point in time. -It sends itself an Echo event in order to measure time. --} -getEventsUntilTime :: - (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => - SndSeq.T mode -> - Queue.T -> Port.T -> - Time -> Time -> - IO [Event.T] -getEventsUntilTime h q p r t = do --- putStrLn $ "schedule echo for " ++ show (milliseconds t) - c <- Client.getId h - _ <- Event.output h $ - makeEcho c q p - (RealTime.fromInteger $ div (t * nano) r) - (Event.Custom 0 0 0) - _ <- Event.drainOutput h - getEventsUntilEcho c h - - -makeEcho :: - Client.T -> Queue.T -> Port.T -> - RealTime.T -> Event.Custom -> Event.T -makeEcho c q p t dat = - (Event.simple - (Addr.Cons c Port.unknown) - (Event.CustomEv Event.Echo dat)) - { Event.queue = q - , Event.timestamp = Event.RealTime t - , Event.dest = Addr.Cons { - Addr.client = c, - Addr.port = p - } - } - - -{- | -The client id may differ from the receiving sequencer. -I do not know, whether there are circumstances, where this is useful. --} -getEventsUntilEcho :: - (SndSeq.AllowInput mode) => - Client.T -> SndSeq.T mode -> IO [Event.T] -getEventsUntilEcho c h = - let loop = do - ev <- Event.input h - let abort = - case Event.body ev of - Event.CustomEv Event.Echo _ -> - c == Addr.client (Event.source ev) - _ -> False - if abort - then - case Event.timestamp ev of - Event.RealTime t -> do --- putStrLn $ "got Echo at: " ++ show (RealTime.toInteger t :: Double) - return [] - _ -> error "unsupported time stamp type" - else liftM (ev:) loop - in loop - - -check :: Monad m => Bool -> String -> m () -> m () -check b msg act = - if not b - then trace msg $ return () - else act - -unsafeAddChunkToBuffer :: (Storable a, Num a) => - SVST.Vector s a -> Int -> SV.Vector a -> ST s () -unsafeAddChunkToBuffer v start xs = - let go i j = - if j >= SV.length xs - then return () - else - SVST.unsafeModify v i (SV.index xs j +) >> - go (i + 1) (j + 1) - in check (start>=0) - ("start negative: " ++ show (start, SV.length xs)) $ - check (start <= SVST.length v) - ("start too late: " ++ show (start, SV.length xs)) $ - check (start+SV.length xs <= SVST.length v) - ("end too late: " ++ show (start, SV.length xs)) $ - go start 0 - -arrange :: - (Storable a, Num a) => - Int -> - [(Int, SV.Vector a)] -> - SV.Vector a -arrange size evs = - SVST.runSTVector (do - v <- SVST.new size 0 - mapM_ (uncurry $ unsafeAddChunkToBuffer v) evs - return v) - - -type Pitch = Word8 -type Velocity = Word8 - -data OscillatorState a = OscillatorState a a Int - -{- -type ToneSequence a = - (Maybe (Int, OscillatorState a), - [(Int, Int, OscillatorState a)]) - -startTone :: ToneSequence a -> ToneSequence a --} - -stopTone :: - Int -> - (Maybe (Int, OscillatorState a), - [(Int, Int, OscillatorState a)]) -> - [(Int, Int, OscillatorState a)] -stopTone stopTime (mplaying, finished) = - case mplaying of - Just (startTime, osci) -> - (startTime, stopTime-startTime, osci) : finished - Nothing -> finished - -renderTone :: - (Storable a, Floating a) => - Int -> OscillatorState a -> - (SV.Vector a, OscillatorState a) -renderTone dur state@(OscillatorState amp freq phase) = - if dur<0 - then - trace ("renderTone: negative duration " ++ show dur) $ - (SV.empty, state) - else - let gain = 0.9999 - in (SV.zipWith (\y k -> y * sin (2*pi*fromIntegral k * freq)) - (SV.iterateN dur (gain*) amp) - (SV.iterateN dur (1+) phase), - OscillatorState (amp*gain^dur) freq (phase+dur)) - -amplitudeFromVelocity :: - (Floating y) => - Velocity -> y -amplitudeFromVelocity vel = - 4 ** ((fromIntegral vel - 64) / 128) - -frequencyFromPitch :: - (Floating y) => - Pitch -> y -frequencyFromPitch pitch = - 440 * 2 ** (fromIntegral (fromIntegral pitch + 3 - 6*12 :: Int) / 12) - -normalizeNote :: Event.NoteEv -> Event.Note -> (Event.NoteEv, Velocity) -normalizeNote notePart note = - case Event.noteVelocity note of - velocity -> - case notePart of - Event.NoteOn -> - if velocity == 0 - then (Event.NoteOff, 64) - else (Event.NoteOn, velocity) - _ -> (notePart, velocity) - -processEvents :: - (Storable a, Floating a, Monad m) => - Int -> - PCM.SampleFreq -> - [StampedEvent] -> - MS.StateT (Time, Map.Map Pitch (OscillatorState a)) m [(Int, SV.Vector a)] -processEvents size rate input = do - (chunkTime, oscis0) <- MS.get - let pendingOscis = - fmap - (\(mplaying, finished) -> - let mplayingNew = - fmap - (\(start,s0) -> - case renderTone (size-start) s0 of - (chunk, s1) -> ((start,chunk), s1)) - mplaying - in (fmap snd mplayingNew, - maybe id (\p -> (fst p :)) mplayingNew $ - map - (\(start, dur, s) -> (start, fst $ renderTone dur s)) - finished)) $ - foldl - (\oscis (time,ev) -> - case Event.body ev of - Event.NoteEv noteEv note -> - case normalizeNote noteEv note of - (Event.NoteOn, velocity) -> - Map.insertWith - (\(newOsci, []) s -> - {- - A key may be pressed that was already pressed. - This should not happen, but we must be prepared for it. - Thus we call stopTone. - -} - (newOsci, stopTone time s)) - (Event.noteNote note) - (Just (time, - OscillatorState - (0.2 * amplitudeFromVelocity velocity) - (frequencyFromPitch (Event.noteNote note) / - fromIntegral rate) - 0), - []) - oscis - (Event.NoteOff, _) -> - Map.adjust - (\s -> - {- - A key may be released that was not pressed. - This should not happen, but we must be prepared for it. - Thus stopTone also handles that case. - -} - (Nothing, stopTone time s)) - (Event.noteNote note) - oscis - _ -> oscis - _ -> oscis) - (fmap (\s -> (Just (0, s), [])) oscis0) - (map (\(time,ev) -> (fromInteger (time-chunkTime), ev)) input) - MS.put (chunkTime, Map.mapMaybe fst pendingOscis) - return (concatMap snd $ Map.elems pendingOscis) - - -write :: - (PCM.SampleFmt a) => - Core.Pcm -> SV.Vector a -> IO () -write h xs = - SVB.withStartPtr xs $ PCM.alsaWrite h - - -{- -Caution: - - MIDI clock and PCM clock are quite different: - After running the synth for about an hour - I got messages like "start too late: (8969,0)", - that is, the MIDI clock was about 9000/44100 seconds - ahead of the PCM clock. --} -main :: IO () -main = - bracket openPCM closePCM $ \(size,rate,h) -> do - putStrLn $ "period size: " ++ show size - putStrLn $ "sample rate: " ++ show rate - withInPort SndSeq.Block $ \sq port -> - Queue.with sq $ \ q -> - do setTimestamping sq port q - Queue.control sq q Event.QueueStart 0 Nothing - _ <- Event.drainOutput sq - write h (SV.replicate (2*size) 0 :: SV.Vector Float) - flip MS.evalStateT (0,Map.empty) $ forever $ do - startTime <- MS.gets fst - let stopTime = startTime + fromIntegral size - evs <- - liftIO $ - getStampedEventsUntilTime sq q port (fromIntegral rate) stopTime - chunks <- processEvents size rate evs - liftIO $ - write h (arrange size chunks :: SV.Vector Float) - MS.modify $ \(_,ss) -> (stopTime, ss) rmfile ./examples/synth.hs hunk ./examples/volume_meter.hs 1 -import Sound.ALSA.PCM - (SoundFmt(SoundFmt), sampleFreq, soundSourceRead, - SoundSource, alsaSoundSource, withSoundSource, ) - -import Foreign - (allocaArray, peekArray, - Storable, Ptr, castPtr, ) -import Data.Int (Int16, ) - -bufSize :: Int -bufSize = 1000 - -inputFormat :: SoundFmt Int16 -inputFormat = SoundFmt { sampleFreq = 8000 } - - -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 Int16 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 rmfile ./examples/volume_meter.hs rmdir ./examples hunk ./debug/Sound/ALSA/PCM/Debug.hs 1 -module Sound.ALSA.PCM.Debug where - -import qualified System.IO as IO -import Control.Concurrent (myThreadId, ) - -put :: String -> IO () -put s = - do t <- myThreadId - IO.hPutStrLn IO.stderr $ "Sound.ALSA.PCM, " ++ show t ++ ": " ++ s rmfile ./debug/Sound/ALSA/PCM/Debug.hs rmdir ./debug/Sound/ALSA/PCM rmdir ./debug/Sound/ALSA rmdir ./debug/Sound rmdir ./debug hunk ./LICENSE 1 -Copyright (c) 2009-2010 Henning Thielemann -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. rmfile ./LICENSE hunk ./Makefile 1 -ghci: - ghci -i:src:debug:dist/build -lasound -Wall src/Sound/ALSA/PCM.hs - -testbuild: - runhaskell Setup configure --user -fdebug -fbuildExamples -fbuildTests - runhaskell Setup build - runhaskell Setup haddock - runhaskell Setup clean - runhaskell Setup configure --user -f-debug - runhaskell Setup build rmfile ./Makefile hunk ./Setup.lhs 1 -#!/usr/bin/env runghc - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain rmfile ./Setup.lhs hunk ./alsa-pcm.cabal 1 -Name: alsa-pcm -Version: 0.5.0.1 -Copyright: Bjorn Bringert, Iavor S. Diatchki, Henning Thielemann -Maintainer: Henning Thielemann -Author: Henning Thielemann , Bjorn Bringert , Iavor S. Diatchki -Category: Sound, Music -License: BSD3 -License-file: LICENSE -Homepage: http://www.haskell.org/haskellwiki/ALSA -Stability: Experimental -Build-Type: Simple -Cabal-Version: >= 1.8 - -Synopsis: Binding to the ALSA Library API (PCM audio). -Description: - This package provides access to ALSA realtime audio signal input and output. - For MIDI support see alsa-seq. - -Source-Repository head - type: darcs - location: http://code.haskell.org/alsa/pcm/ - -Source-Repository this - type: darcs - location: http://code.haskell.org/alsa/pcm/ - tag: 0.5.0.1 - -Flag buildExamples - description: Build example executables - default: False - -Flag buildSynthesizer - description: Build example synthesizer (needs alsa-seq, too) - default: False - -Flag debug - description: Enable debug output - default: False - -Library - Build-depends: - alsa-core >=0.5 && <0.6, - sample-frame >=0.0.1 && <0.1, - array >= 0.1 && <0.4, - extensible-exceptions >=0.1.1 && <0.2, - base >= 3 && <5 - - Hs-Source-Dirs: src - If flag(debug) - Hs-Source-Dirs: debug - Else - Hs-Source-Dirs: nodebug - - Exposed-Modules: - Sound.ALSA.PCM - - Other-modules: - Sound.ALSA.PCM.Core - Sound.ALSA.PCM.C2HS - Sound.ALSA.PCM.Debug - - GHC-Options: -Wall -fwarn-tabs - Includes: alsa/asoundlib.h - PkgConfig-depends: alsa >= 1.0.14 - - -Executable alsa-minisynth - Main-Is: synth.hs - If !flag(buildSynthesizer) - Buildable: False - Hs-Source-Dirs: src, debug, examples - GHC-Options: -Wall -threaded - Other-modules: - Sound.ALSA.PCM - Sound.ALSA.PCM.Core - Sound.ALSA.PCM.C2HS - Build-Depends: - alsa-seq >=0.5 && <0.6, - alsa-core >=0.5 && <0.6, - storablevector >=0.2.7 && <0.3, - sample-frame >=0.0.1 && <0.1, - base >=3 && <5 - -Executable alsa-duplex - Main-Is: duplex.hs - If !flag(buildExamples) - Buildable: False - Hs-Source-Dirs: src, debug, examples - GHC-Options: -Wall -threaded - Other-modules: - Sound.ALSA.PCM - Sound.ALSA.PCM.Core - Sound.ALSA.PCM.C2HS - Build-Depends: - alsa-core >=0.5 && <0.6, - sample-frame >=0.0.1 && <0.1, - base >=3 && <5 - -Executable alsa-play - Main-Is: play.hs - If !flag(buildExamples) - Buildable: False - Hs-Source-Dirs: src, debug, examples - GHC-Options: -Wall -threaded - Other-modules: - Sound.ALSA.PCM - Sound.ALSA.PCM.Core - Sound.ALSA.PCM.C2HS - Build-Depends: - alsa-core >=0.5 && <0.6, - sample-frame >=0.0.1 && <0.1, - base >=3 && <5 - -Executable alsa-record - Main-Is: record.hs - If !flag(buildExamples) - Buildable: False - Hs-Source-Dirs: src, debug, examples - GHC-Options: -Wall -threaded - Other-modules: - Sound.ALSA.PCM - Sound.ALSA.PCM.Core - Sound.ALSA.PCM.C2HS - Build-Depends: - alsa-core >=0.5 && <0.6, - sample-frame >=0.0.1 && <0.1, - base >=3 && <5 - -Executable alsa-volume-meter - Main-Is: volume_meter.hs - If !flag(buildExamples) - Buildable: False - Hs-Source-Dirs: src, debug, examples - GHC-Options: -Wall -threaded - Other-modules: - Sound.ALSA.PCM - Sound.ALSA.PCM.Core - Sound.ALSA.PCM.C2HS - Build-Depends: - alsa-core >=0.5 && <0.6, - sample-frame >=0.0.1 && <0.1, - base >=3 && <5 rmfile ./alsa-pcm.cabal } Context: [synth: comment on observation of time drift between MIDI and PCM alsa@henning-thielemann.de**20111218224947] [synth.addChunkToBuffer: checks distinguish between start too late and end too late alsa@henning-thielemann.de**20111218224846] [synth: MIDI time measurement based on sample period alsa@henning-thielemann.de**20111218223014] [synth: percussive envelope for the rendered tone alsa@henning-thielemann.de**20111218204649] [synth: initialize buffer with two empty periods alsa@henning-thielemann.de**20111218203744] [synth: debug messages for notes out of time order alsa@henning-thielemann.de**20111218193616] [synth: handle NoteOffs that are coded as NoteOns alsa@henning-thielemann.de**20111218115945] [synth: receive MIDI messages and render tone sequence alsa@henning-thielemann.de**20111218091030] [synth: configure period size in number of samples instead of microseconds alsa@henning-thielemann.de**20111217191014] [synth: sketch that emits a constant sine tone alsa@henning-thielemann.de**20111217172336] [PCM.alsaOpen: also show requested buffer size alsa@henning-thielemann.de**20111216212313] [PCM.alsaSoundSink: use alsaSoundSinkTime alsa@henning-thielemann.de**20111216170556] [Cabal: formatted preamble alsa@henning-thielemann.de**20111127131307] [Cabal: darcs repository moved to code.haskell.org/alsa/pcm alsa@henning-thielemann.de**20111127131218] [expand tab characters alsa@henning-thielemann.de**20111127130645] [PCM.alsaRead, alsaWrite: tail recursive alsa@henning-thielemann.de**20111127130444] [example/play: play all files alsa@henning-thielemann.de**20110408210408] [example/duplex: explicitly ignore ThreadId of forkOS alsa@henning-thielemann.de**20110305175246] [play: use 'default' output device alsa@henning-thielemann.de**20110305094406] [Cabal: Extra-Libraries -> PkgConfig-Depends alsa@henning-thielemann.de**20110305094233] [CHS: remove unnecessary import of poke alsa@henning-thielemann.de**20110103134138] [PCM: simplify ignoring result from 'write' functions alsa@henning-thielemann.de**20110103133700] [ALSA.PCM.withHwParams, withSwParams: use bracket for params_malloc alsa@henning-thielemann.de**20101220224703] [Cabal: flag debug for enabling debug output only on request alsa@henning-thielemann.de**20101031163626] [bump version to 0.5.0.1 alsa@henning-thielemann.de**20100920195842] [TAG 0.5 alsa@henning-thielemann.de**20100920195821] Patch bundle hash: 3c0168a7461a895d43810ff3b6f34674d4cf3ddc