diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,9 @@ +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. 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/alsa-pcm.cabal b/alsa-pcm.cabal new file mode 100644 --- /dev/null +++ b/alsa-pcm.cabal @@ -0,0 +1,112 @@ +Name: alsa-pcm +Version: 0.5 +Copyright: Bjorn Bringert, Iavor S. Diatchki, Henning Thielemann +Maintainer: Henning Thielemann +Author: 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/~thielema/alsa-pcm/ + +Source-Repository this + type: darcs + location: http://code.haskell.org/~thielema/alsa-pcm/ + tag: 0.5 + +Flag buildExamples + description: Build example executables + 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 + + Exposed-Modules: + Sound.ALSA.PCM + + Other-modules: + Sound.ALSA.PCM.Core + Sound.ALSA.PCM.C2HS + + GHC-Options: -Wall + Includes: alsa/asoundlib.h + Extra-libraries: asound + + +Executable alsa-duplex + Main-Is: duplex.hs + If !flag(buildExamples) + Buildable: False + Hs-Source-Dirs: src, 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, 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, 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, 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 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.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 + 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,27 @@ +import Sound.ALSA.PCM + (SoundFmt(SoundFmt), copySound, sampleFreq, + fileSoundSource, alsaSoundSink, ) + +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] -> 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,27 @@ +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 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.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 diff --git a/src/Sound/ALSA/PCM.hs b/src/Sound/ALSA/PCM.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/PCM.hs @@ -0,0 +1,485 @@ +{-# 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.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.Concurrent (myThreadId, ) +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 +-- + + +debug :: String -> IO () +debug s = + do t <- myThreadId + IO.hPutStrLn IO.stderr $ show t ++ ": " ++ s + +alsaOpen :: SampleFmt y => + String -- ^ device, e.g @"default"@ + -> SoundFmt y + -> SoundBufferTime + -> PcmStream + -> IO Pcm +alsaOpen dev fmt time stream = AlsaExc.rethrow $ + do debug "alsaOpen" + h <- pcm_open dev stream 0 + (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 $ "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) $ + callocaArray fmt period_size $ \buf -> + do 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 = + 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 = AlsaExc.rethrow $ + do debug "alsaClose" + pcm_drain pcm + pcm_close pcm + +alsaStart :: Pcm -> IO () +alsaStart pcm = AlsaExc.rethrow $ + do debug "alsaStart" + pcm_prepare pcm + pcm_start pcm + + +-- FIXME: use pcm_drain for sinks? +alsaStop :: Pcm -> IO () +alsaStop pcm = AlsaExc.rethrow $ + do debug "alsaStop" + pcm_drain pcm + +alsaRead :: + SampleFmt y => + Pcm -> Ptr y -> Int -> IO Int +alsaRead h buf n = AlsaExc.rethrow $ + do --debug $ "Reading " ++ show n ++ " samples..." + n' <- pcm_readi h buf n `AlsaExc.catchXRun` handleOverRun + --debug $ "Got " ++ show n' ++ " samples." + if n' < n + then do n'' <- alsaRead h (advancePtr buf n') (n - n') + return (n' + n'') + else return n' + where handleOverRun = do debug "snd_pcm_readi reported buffer over-run" + pcm_prepare h + alsaRead h buf n + +alsaWrite :: + SampleFmt y => + Pcm -> Ptr y -> Int -> IO () +alsaWrite h buf n = AlsaExc.rethrow $ + do alsaWrite_ h buf n + return () + +alsaWrite_ :: + SampleFmt y => + Pcm -> Ptr y -> Int -> IO Int +alsaWrite_ h buf n = + do --debug $ "Writing " ++ show n ++ " samples..." + n' <- pcm_writei h buf n `AlsaExc.catchXRun` handleUnderRun + --debug $ "Wrote " ++ show n' ++ " samples." + if (n' /= n) + then do n'' <- alsaWrite_ h (advancePtr buf n') (n - n') + return (n' + n'') + else return n' + where handleUnderRun = do debug "snd_pcm_writei reported buffer under-run" + pcm_prepare h + alsaWrite_ h buf n + + +alsaSoundSource :: + SampleFmt y => + String -> SoundFmt y -> SoundSource y Pcm +alsaSoundSource dev fmt = + (nullSoundSource fmt) { + soundSourceOpen = alsaOpen dev fmt defaultBufferTime PcmStreamCapture, + soundSourceClose = alsaClose, + soundSourceStart = alsaStart, + soundSourceStop = alsaStop, + soundSourceRead = alsaRead + } + +alsaSoundSink :: + SampleFmt y => + String -> SoundFmt y -> SoundSink y Pcm +alsaSoundSink dev fmt = + (nullSoundSink fmt) { + soundSinkOpen = alsaOpen dev fmt defaultBufferTime PcmStreamPlayback, + soundSinkClose = alsaClose, + soundSinkStart = alsaStart, + soundSinkStop = alsaStop, + soundSinkWrite = alsaWrite + } + +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) diff --git a/src/Sound/ALSA/PCM/C2HS.hs b/src/Sound/ALSA/PCM/C2HS.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/PCM/C2HS.hs @@ -0,0 +1,237 @@ +-- 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, poke, ) +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 diff --git a/src/Sound/ALSA/PCM/Core.chs b/src/Sound/ALSA/PCM/Core.chs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/PCM/Core.chs @@ -0,0 +1,309 @@ +{-# 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)