DSPlayer.hs

{- 2009 Daniel van den Eijkel <dvde@gmx.net> -}

module Sound.Hommage.DSPlayer.DSPlayer 
 ( DSPlayer (..)
 , startDSPlayer
 )
 where

import qualified Sound.Win32.DirectSound as DS

import Control.Monad
import Data.Maybe
import Foreign
import System.IO
---------------------------------------------------------------------------------------------------
-- | The DSPlayer object is given to the @startDSPlayer@ action. It contains all necessary 
--  information like sampling rate, buffer size, a stereo flag and the fillbuffer callback function.
data DSPlayer = DSPlayer { sampleRateDS :: Int  -- ^ 44100 for example
                         , bufferSizeDS :: Int  -- ^ 1024 for example
                         , isStereoDS :: Bool   
                         , fillBufferCallbackDS :: DS.FillBufferCallback Int16 -- ^ @Ptr a -> Word32 -> IO ()@  Length: bufferSizeDS multiplied with 2(stereo) or 1(mono)
                         }
---------------------------------------------------------------------------------------------------
-- | Opens the Audio Driver, creates a Sound Buffer and starts playback. 
--   Returns a stop-action. NOTE: Stopping does not work well: 
--   Restarting the sound after stopping does not work currently.
--
--   After calling this action, the fillbufferCallbackDS function will be called iteratively.
--   For stereo output, the values are interleaved.
startDSPlayer :: DSPlayer -> IO (IO ()) 
startDSPlayer dsplayer = do 
  ds <- openAudioDriver 
  sb <- openSoundBuffer ds (sampleRateDS dsplayer) (bufferSizeDS dsplayer) (isStereoDS dsplayer)
  stopaudio <- DS.playWithDoubleBuffering sb (fillBufferCallbackDS dsplayer)
  return stopaudio
---------------------------------------------------------------------------------------------------
openSoundBuffer :: DS.DirectSound -> Int -> Int -> Bool -> IO DS.SoundBuffer
openSoundBuffer ds sampleRate bufSize True  = openStereoSoundBuffer ds sampleRate bufSize
openSoundBuffer ds sampleRate bufSize False = openMonoSoundBuffer ds sampleRate bufSize

openStereoSoundBuffer :: DS.DirectSound -> Int -> Int -> IO DS.SoundBuffer
openStereoSoundBuffer ds sampleRate bufSize = do
  let waveFormatX = DS.makeWaveFormatX sampleRate 2 DS.SampleInt16
  sb <- DS.createSoundBuffer ds waveFormatX (2*bufSize) >>= \msb -> case msb of
    Left err -> error err 
    Right sb -> return sb
  return sb

openMonoSoundBuffer :: DS.DirectSound -> Int -> Int -> IO DS.SoundBuffer
openMonoSoundBuffer ds sampleRate bufSize = do
  let waveFormatX = DS.makeWaveFormatX sampleRate 1 DS.SampleInt16
  sb <- DS.createSoundBuffer ds waveFormatX (2*bufSize) >>= \msb -> case msb of     -- 1*bufsize ???
    Left err -> error err 
    Right sb -> return sb
  return sb
-------------------------------------------------------------------------------
openAudioDriver :: IO DS.DirectSound
openAudioDriver = do  
  drvlist <- DS.enumerateDrivers
  drv <- case drvlist of
    [] -> error "no audio device found"
    [drv] -> return drv
    _ -> selectAudioDriver drvlist (\d -> return (DS.drv_desc d))  
  hwnd <- DS.getConsoleHWND_hack
 -- putStrLn $ "hwnd = " ++ show hwnd
  ds <- DS.directSoundCreate (Just drv) hwnd >>= \mds -> case mds of
    Left err -> error err
    Right ds -> return ds
  return ds
  
selectAudioDriver :: [b] -> (b -> IO [Char]) -> IO b
selectAudioDriver srclist getName = do
  names <- mapM getName srclist
  forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show (i :: Int) ++ ": " ++ name
  let nsrc = length srclist
  src <- case srclist of
    []  -> error "no devices found"
    [x] -> return x
    _   -> do
      putStrLn "please select a device"
      l <- getLine
      let k = case maybeRead l of
        { Nothing -> nsrc
        ; Just m  -> if m<1 || m>nsrc then nsrc else m
        }
      putStrLn $ "device #" ++ show k ++ " selected."
      return $ srclist!!(k-1)
  return src      

maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of 
  [(x,"")] -> Just x
  _        -> Nothing