Some code I wrote to make playing with openal easier

OpenalUtil

module Sound.OpenAL.Util
  ( withDevice
  , withDefaultDeviceAndContext
  , createBuffer
  , createBufferData
  , createBufferFromData
  , createBufferFromSample
  , whileSourceIsPlaying
  , sleep
  , getSamplingRate
  , stream
  , streamToSource
  , printAttribs
  , printSample
  )
  where

import Control.Applicative -- ((<*>), (<$>))
import Control.Concurrent (threadDelay)
import Control.Exception (bracket)
import Control.Monad (forM_)
import Data.Int (Int16)
import Data.List (find)
import Data.List.Split (chunk)
import Data.Maybe (fromJust)
import Data.Word (Word16)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Array (newArray)
import Foreign.Ptr (plusPtr)
import Foreign.Storable (sizeOf)
import Sound.OpenAL (play, ($=), get, genObjectNames)
import Sound.OpenAL.AL.Buffer (MemoryRegion(..), Buffer, BufferData(..), bufferData)
import Sound.OpenAL.AL.Format (Format(..))
import Sound.OpenAL.AL.Source (Source, buffersProcessed, queueBuffers, unqueueBuffers, sourceState, SourceState(..), secOffset)
import Sound.OpenAL.ALC.Context (Context, createContext, destroyContext, currentContext, allAttributes, ContextAttribute(..))
import Sound.OpenAL.ALC.Device (Device, openDevice, closeDevice)
import System.IO (hPutStrLn, stderr)
import Text.Printf (printf)
import qualified Data.Vector.Storable             as VS
import qualified Sound.File.Sndfile               as SF
import qualified Sound.File.Sndfile.Buffer.Vector as BV
import Sound.Types

-- ----------------------------------------
-- Openal util

withDevice :: (Device -> IO ()) -> IO ()
withDevice f =
    bracket
      (openDevice Nothing)
      (\m -> case m of Just d -> closeDevice d >> return ()
                       Nothing -> return ())
      (\m -> case m of Just d -> f d
                       Nothing -> hPutStrLn stderr "openDevice failed")

withDefaultDeviceAndContext :: (Device -> Context -> IO ()) -> IO ()
withDefaultDeviceAndContext f =
    withDevice g
  where
    g device =
      bracket
        (fromJust `fmap` createContext device [])
        destroyContext
        (\c -> withDevice $ \d -> do
          currentContext $= Just c
          f d c)

createBuffer :: BufferData a -> IO Buffer
createBuffer bd = do
    [b] <- genObjectNames 1 :: IO [Buffer]
    bufferData b $= bd
    return b

createBufferData :: RealFrac a => SamplingRate -> [a] -> IO (BufferData Int16)
createBufferData sr xs = do
    ptr <- newArray ss
    return $ BufferData (MemoryRegion ptr sz) Mono16 (realToFrac sr)
  where
    ss = map float2Int16 xs
    sz = fromIntegral $ length ss * sizeOf (head ss)
    float2Int16 :: RealFrac a => a -> Int16
    float2Int16 f = truncate $ 32767 * f

createBufferFromData :: RealFrac a => SamplingRate -> [a] -> IO Buffer
createBufferFromData sr xs = createBufferData sr xs >>= createBuffer

-- XXX not really Stereo
createBufferFromSample :: FilePath -> IO Buffer
createBufferFromSample fp = do
    (info, Just x) <- SF.readFile fp :: IO (SF.Info, Maybe (BV.Buffer Word16))
    let (ptr, off, len) = VS.unsafeToForeignPtr (BV.fromBuffer x)
    withForeignPtr ptr $ \p ->
      createBuffer $ BufferData (MemoryRegion (plusPtr p off) (fromIntegral $ len - off)) Stereo16 (fromIntegral $ SF.samplerate info)

whileSourceIsPlaying :: Source -> IO () -> IO ()
whileSourceIsPlaying s f =
    g
  where
    g = get (sourceState s) >>= \state ->
          case state of
            Playing -> f >> g
            _       -> return ()

getSamplingRate :: Floating a => Device -> IO (Maybe a)
getSamplingRate device =
    fmap freq . find isFreq <$> get (allAttributes device)
  where
    isFreq (Frequency _) = True
    isFreq _ = False
    freq (Frequency f) = realToFrac f
    freq _ = error "hfe"

printAttribs :: Device -> IO ()
printAttribs device =
    get (allAttributes device) >>= print

printSample :: Sample -> IO ()
printSample = printf "%0.3f\n"

sleep :: Duration -> IO ()
sleep sec =
    let usec = max 0 (round $ sec*1e6)
    in threadDelay usec

stream :: Int -> Int -> SamplingRate -> [Sample] -> IO ()
stream nb sb sr ss = do
    [s] <- genObjectNames 1 :: IO [Source]
    streamToSource s nb sb sr ss

-- nb = number of buffers, sb = samples to buffer, sr = sampleRate, ss = samples
streamToSource :: Source -> Int -> Int -> SamplingRate -> [Sample] -> IO ()
streamToSource s nb sb sr ss = do
    bs <- genObjectNames nb :: IO [Buffer]
    initBuffers bs chunks
    play [s]
    update (cycle bs) (drop (length bs) chunks)
    whileSourceIsPlaying s (putStrLn "still playing" >> sleep 0.1)
  where
    chunks = chunk sb ss
    --
    initBuffers bs cs = do
        let todo = zip bs cs
            todoLen = length todo
        forM_ todo $ \(b,c) -> do
          bd <- createBufferData sr c
          bufferData b $= bd
        queueBuffers s (take todoLen bs)
    --
    update _ [] = return ()
    update [] _ = return ()
    update bs cs = do
        nproc <- fromIntegral `fmap` get (buffersProcessed s)
        let todo = zip (take nproc bs) cs
            todoLen = length todo
        forM_ todo $ \(b,c) -> do
          unqueueBuffers s [b]
          bd <- createBufferData sr c
          bufferData b $= bd
          queueBuffers s [b]
        state <- get (sourceState s)
        case state of
          Playing -> return ()
          _ -> play [s]
        secPlayed <- get (secOffset s)
        sleep . realToFrac $ fromIntegral sb/sr - realToFrac secPlayed
        update (drop nproc bs) (drop todoLen cs)