DirectSound (empty) → 0.0.0
raw patch · 5 files changed
+1195/−0 lines, 5 filesdep +Win32dep +basesetup-changed
Dependencies added: Win32, base
Files
- DirectSound.cabal +44/−0
- LICENSE +29/−0
- Setup.lhs +3/−0
- Sound/Win32/DirectSound.hs +1032/−0
- example/DirectSound_playback_example.hs +87/−0
+ DirectSound.cabal view
@@ -0,0 +1,44 @@+Name: DirectSound+Version: 0.0.0+Synopsis: Partial binding to the Microsoft DirectSound API.+Description: Partial binding to the Microsoft DirectSound API.+ See the example program for a simple stereo playback.+License: BSD3+License-file: LICENSE+Author: Balazs Komuves+Copyright: (c) 2009 Balazs Komuves+Maintainer: bkomuves (plus) hackage (at) gmail (dot) com+Stability: Unstable+Homepage: http://code.haskell.org/~bkomuves/+Category: Sound+Tested-With: GHC == 7.4.2+Cabal-Version: >= 1.6+Build-Type: Simple++extra-source-files: example/DirectSound_playback_example.hs++source-repository head+ type: darcs+ location: http://code.haskell.org/~bkomuves/projects/DirectSound/++Flag splitBase+ Description: Choose the new smaller, split-up base package.++Library+ if flag(splitBase)+ Build-Depends: base >= 3 && < 5+ else+ Build-Depends: base < 3++ Build-Depends: Win32+ + extra-libraries: dsound+ + Exposed-Modules: Sound.Win32.DirectSound++ -- ghc-options: -threaded+ + Extensions: ForeignFunctionInterface, CPP, + EmptyDataDecls, TypeSynonymInstances + Hs-Source-Dirs: .+
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, Balazs Komuves+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- 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.+ +- Neither names of the copyright holders nor the names of the contributors+may be used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT OWNER +OR CONTRIBUTORS 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.+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Sound/Win32/DirectSound.hs view
@@ -0,0 +1,1032 @@++{-+(c) 2009 Balazs Komuves <bkomuves@gmail.com>+-}++-- | Partial binding to the DirectSound API.++{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, GeneralizedNewtypeDeriving #-}+module Sound.Win32.DirectSound where++-------------------------------------------------------------------------------++import Control.Monad+import Control.Concurrent+import Control.Concurrent.MVar++import Data.Bits+import Data.Word+import Data.Maybe++import Graphics.Win32.Window (c_FindWindow)+import System.Win32.File (closeHandle)+import System.Win32.Types++import Foreign+import Foreign.C++-------------------------------------------------------------------------------+-- helper functions++-- adjustMVar :: MVar a -> (a -> a) -> IO ()+-- adjustMVar m f = takeMVar m >>= \x -> putMVar m (f x)++peekMaybe :: Storable a => Ptr a -> IO (Maybe a)+peekMaybe p = + if p == nullPtr+ then return Nothing+ else liftM Just $ peek p+ +withMaybe :: Storable a => Maybe a -> (Ptr a -> IO b) -> IO b+withMaybe Nothing action = action nullPtr+withMaybe (Just x) action = with x action++-------------------------------------------------------------------------------++type Method obj fun = Ptr obj -> fun++-- type HRESULT = UINT -- 2013: already defined by System.Win32.Types+type HWND = HANDLE++--data DSBuffer+data DSCaps ++type IID = GUID+type RefIID = Ptr IID++data DSFXDesc++data DSBufferCaps = DSBufferCaps+ { dsbc_Size :: DWORD+ , dsbc_Flags :: DWORD+ , dsbc_BufferBytes :: DWORD+ , dsbc_UnlockTransferRate :: DWORD+ , dsbc_PlayCpuOverhead :: DWORD+ }+ +instance Storable DSBufferCaps where+ alignment _ = 4+ sizeOf _ = 20+ poke = undefined+ peek p = do+ sz <- peek (castPtr p )+ fl <- peek (castPtr p `plusPtr` 4)+ bb <- peek (castPtr p `plusPtr` 8)+ tr <- peek (castPtr p `plusPtr` 12)+ oh <- peek (castPtr p `plusPtr` 16) + return $ DSBufferCaps sz fl bb tr oh+ +-------------------------------------------------------------------------------++-- see mmreg.h+data WaveFormatTag + = WavePCM + | WaveADPCM + | WaveFloat+ +marshalWaveFormatTag :: WaveFormatTag -> Word16+marshalWaveFormatTag tag = case tag of+ WavePCM -> 1+ WaveADPCM -> 2+ WaveFloat -> 3 + +data WaveFormatX = WaveFormatX+ { wFormatTag :: Word16+ , nChannels :: Word16+ , nSamplesPerSec :: Word32+ , nAvgBytesPerSec :: Word32+ , nBlockAlign :: Word16+ , wBitsPerSample :: Word16+-- , cbSize :: Word16+ }+ +instance Storable WaveFormatX where+ alignment _ = 4+ sizeOf _ = 18+ peek = undefined+ poke p wf = do+ poke (castPtr p ) (wFormatTag wf)+ poke (castPtr p `plusPtr` 2) (nChannels wf)+ poke (castPtr p `plusPtr` 4) (nSamplesPerSec wf)+ poke (castPtr p `plusPtr` 8) (nAvgBytesPerSec wf)+ poke (castPtr p `plusPtr` 12) (nBlockAlign wf) + poke (castPtr p `plusPtr` 14) (wBitsPerSample wf) + poke (castPtr p `plusPtr` 16) (0::Word16) -- (cbSize wf) ++data Channels = Mono | Stereo+data Format = SampleInt16 | SampleFloat++makeWaveFormatX + :: Int -- ^ sample rate+ -> Int -- ^ number of channels+ -> Format -- ^ sample format+ -> WaveFormatX +makeWaveFormatX samplerate nchn fmt = wfx where+ bps = case fmt of + SampleInt16 -> 16+ SampleFloat -> 32+ nba = (bps `div` 8) * nchn + wfx = WaveFormatX + { wFormatTag = marshalWaveFormatTag WavePCM+ , nChannels = fromIntegral nchn+ , nSamplesPerSec = fromIntegral $ samplerate+ , nAvgBytesPerSec = fromIntegral $ nba*samplerate+ , nBlockAlign = fromIntegral $ nba+ , wBitsPerSample = fromIntegral $bps+-- , cbSize = 0+ } + +{- +mono44khzInt16 :: WaveFormatX+mono44khzInt16 = WaveFormatX + { wFormatTag = marshalWaveFormatTag WavePCM+ , nChannels = 1+ , nSamplesPerSec = 44100+ , nAvgBytesPerSec = 2*44100+ , nBlockAlign = 2+ , wBitsPerSample = 16+-- , cbSize = 0+ }++stereo44khzInt16 :: WaveFormatX+stereo44khzInt16 = mono44khzInt16+ { nChannels = 2+ , nAvgBytesPerSec = 4*44100+ , nBlockAlign = 4+ }++stereo48khzInt16 :: WaveFormatX+stereo48khzInt16 = mono44khzInt16+ { nChannels = 2+ , nSamplesPerSec = 48000+ , nAvgBytesPerSec = 4*48000+ , nBlockAlign = 4+ }++mono44khzFloat :: WaveFormatX+mono44khzFloat = mono44khzInt16+ { nAvgBytesPerSec = 4*44100+ , nBlockAlign = 4+ , wBitsPerSample = 32+ }++stereo44khzFloat :: WaveFormatX+stereo44khzFloat = mono44khzFloat + { nChannels = 2+ , nAvgBytesPerSec = 8*44100+ , nBlockAlign = 8+ } +-}+ +-------------------------------------------------------------------------------+ +dsbcaps_PrimaryBuffer = 0x00000001 :: DWORD +dsbcaps_Static = 0x00000002 :: DWORD +dsbcaps_StickyFocus = 0x00004000 :: DWORD +dsbcaps_GlobalFocus = 0x00008000 :: DWORD +dsbcaps_GetCurrentPos2 = 0x00010000 :: DWORD+dsbcaps_CtrlPositionNotify = 0x00000100 :: DWORD++data DSBufferDesc = DSBufferDesc+ { bdesc_flags :: DWORD+ , bdesc_bufferBytes :: DWORD+ , bdesc_waveFormatX :: Ptr WaveFormatX+ , bdesc_3Dalg :: GUID+ } + +{-+withPrimaryDSBufferDesc :: WaveFormatX -> (Ptr DSBufferDesc -> IO a) -> IO a+withPrimaryDSBufferDesc wfx action = + with wfx $ \pwfx -> do+ let flags = dsbcaps_GlobalFocus .|. dsbcaps_GetCurrentPos2 .|. dsbcaps_PrimaryBuffer .|. dsbcaps_CtrlPositionNotify+ bdesc = DSBufferDesc flags 0 pwfx guidNull+ with bdesc $ \p -> action p +-}++-- buffer size is given in frames, not bytes+withSecondaryDSBufferDesc :: WaveFormatX -> Int -> (Ptr DSBufferDesc -> IO a) -> IO a+withSecondaryDSBufferDesc wfx bufsize action = + with wfx $ \pwfx -> do+ let flags = dsbcaps_GlobalFocus .|. dsbcaps_GetCurrentPos2 .|. dsbcaps_CtrlPositionNotify+ bdesc = DSBufferDesc flags (fromIntegral bufsize * fromIntegral (nBlockAlign wfx)) pwfx guidNull+ with bdesc $ \p -> action p + +instance Storable DSBufferDesc where+ alignment _ = 4+ sizeOf _ = 16 + sizeOf (undefined :: Ptr ()) + sizeOf (undefined :: GUID)+ peek = undefined+ poke p bd = do+ poke (castPtr p ) (fromIntegral (sizeOf (undefined :: DSBufferDesc)) :: DWORD) + poke (castPtr p `plusPtr` 4) (bdesc_flags bd)+ poke (castPtr p `plusPtr` 8) (bdesc_bufferBytes bd)+ poke (castPtr p `plusPtr` 12) (0::DWORD)+ poke (castPtr p `plusPtr` 16) (bdesc_waveFormatX bd)+ let k = sizeOf (bdesc_waveFormatX bd)+ poke (castPtr p `plusPtr` (16+k)) (bdesc_3Dalg bd) ++-------------------------------------------------------------------------------++type RefGUID = Ptr GUID++-- A GUID is a 128-bit integer (16 bytes) that can be used across all +-- computers and networks wherever a unique identifier is required. +data GUID = GUID+ { guid_chunk1 :: !Word64+ , guid_chunk2 :: !Word64+ } + deriving (Eq,Show)+ +guidNull :: GUID+guidNull = GUID 0 0 + +instance Storable GUID where+ alignment _ = 4+ sizeOf _ = 16+ peek p = do+ x <- peek (castPtr p )+ y <- peek (castPtr p `plusPtr` 8)+ return (GUID x y)+ poke p (GUID x y) = do+ poke (castPtr p) x+ poke (castPtr p `plusPtr` 8) y++-------------------------------------------------------------------------------++data CooperativeLevel + = CoopNormal+ | CoopPriority+ | CoopExclusive+ | CoopWritePrimary++marshalCooperativeLevel :: CooperativeLevel -> DWORD+marshalCooperativeLevel level = case level of+ CoopNormal -> 0x00000001+ CoopPriority -> 0x00000002+ CoopExclusive -> 0x00000003+ CoopWritePrimary -> 0x00000004+ +-------------------------------------------------------------------------------++{- +DECLARE_INTERFACE_(IDirectSound8, IDirectSound)+{+ // IUnknown methods+ STDMETHOD(QueryInterface) (THIS_ REFIID, LPVOID *) PURE;+ STDMETHOD_(ULONG,AddRef) (THIS) PURE;+ STDMETHOD_(ULONG,Release) (THIS) PURE;++ // IDirectSound methods+ STDMETHOD(CreateSoundBuffer) (THIS_ LPCDSBUFFERDESC pcDSBufferDesc, LPDIRECTSOUNDBUFFER *ppDSBuffer, LPUNKNOWN pUnkOuter) PURE;+ STDMETHOD(GetCaps) (THIS_ LPDSCAPS pDSCaps) PURE;+ STDMETHOD(DuplicateSoundBuffer) (THIS_ LPDIRECTSOUNDBUFFER pDSBufferOriginal, LPDIRECTSOUNDBUFFER *ppDSBufferDuplicate) PURE;+ STDMETHOD(SetCooperativeLevel) (THIS_ HWND hwnd, DWORD dwLevel) PURE;+ STDMETHOD(Compact) (THIS) PURE;+ STDMETHOD(GetSpeakerConfig) (THIS_ LPDWORD pdwSpeakerConfig) PURE;+ STDMETHOD(SetSpeakerConfig) (THIS_ DWORD dwSpeakerConfig) PURE;+ STDMETHOD(Initialize) (THIS_ LPCGUID pcGuidDevice) PURE;++ // IDirectSound8 methods+ STDMETHOD(VerifyCertification) (THIS_ LPDWORD pdwCertified) PURE;+};+-}++type DS8Method fun = Method IDirectSound8 fun++-- IUnknown methods+type QueryInterface = RefIID -> Ptr (Ptr ()) -> IO HRESULT+type AddRef = IO () +type Release = IO () +-- IDirectSound methods+type CreateSoundBuffer = Ptr DSBufferDesc -> Ptr (Ptr ISoundBuffer8) -> Ptr () -> IO HRESULT +type DSGetCaps = Ptr DSCaps -> IO HRESULT +type DuplicateSoundBuffer = Ptr ISoundBuffer8 -> Ptr (Ptr ISoundBuffer8) -> IO HRESULT+type SetCooperativeLevel = HWND -> DWORD -> IO HRESULT+type Compact = IO HRESULT+type GetSpeakerConfig = Ptr DWORD -> IO HRESULT+type SetSpeakerConfig = DWORD -> IO HRESULT+type DSInitialize = Ptr GUID -> IO HRESULT +-- IDirectSound8 methods +type VerifyCertification = DWORD -> IO () ++data IDirectSound8Vtbl = IDirectSound8Vtbl+ { -- IUnknown methods+ ids8_QueryInterface :: FunPtr ( Ptr IDirectSound8 -> QueryInterface )+ , ids8_AddRef :: FunPtr ( Ptr IDirectSound8 -> AddRef )+ , ids8_Release :: FunPtr ( Ptr IDirectSound8 -> Release )+ -- IDirectSound methods+ , ids8_CreateSoundBuffer :: FunPtr ( Ptr IDirectSound8 -> CreateSoundBuffer )+ , ids8_GetCaps :: FunPtr ( Ptr IDirectSound8 -> DSGetCaps )+ , ids8_DuplicateSoundBuffer :: FunPtr ( Ptr IDirectSound8 -> DuplicateSoundBuffer )+ , ids8_SetCooperativeLevel :: FunPtr ( Ptr IDirectSound8 -> SetCooperativeLevel )+ , ids8_Compact :: FunPtr ( Ptr IDirectSound8 -> Compact )+ , ids8_GetSpeakerConfig :: FunPtr ( Ptr IDirectSound8 -> GetSpeakerConfig )+ , ids8_SetSpeakerConfig :: FunPtr ( Ptr IDirectSound8 -> SetSpeakerConfig )+ , ids8_Initialize :: FunPtr ( Ptr IDirectSound8 -> DSInitialize )+ -- IDirectSound8 methods + , ids8_VerifyCertification :: FunPtr ( Ptr IDirectSound8 -> VerifyCertification )+ }+ +newtype IDirectSound8 = IDirectSound8 { unIDirectSound8 :: Ptr IDirectSound8Vtbl } deriving Storable++-- | The Haskell version of the @DirectSound8@ object+data DirectSound = DirectSound8+ { ds_directSound8object :: Ptr IDirectSound8+ , ds_windowHandle :: HWND+ -- IUnknown methods + , ds_queryInterface :: QueryInterface+ , ds_addRef :: AddRef+ , ds_release :: Release+ -- IDirectSound methods+ , ds_createSoundBuffer :: CreateSoundBuffer+ , ds_getCaps :: DSGetCaps+ , ds_duplicateSoundBuffer :: DuplicateSoundBuffer+ , ds_setCooperativeLevel :: SetCooperativeLevel+ , ds_compact :: Compact+ , ds_getSpeakerConfig :: GetSpeakerConfig+ , ds_setSpeakerConfig :: SetSpeakerConfig+ , ds_initialize :: DSInitialize+ -- IDirectSound8 methods + , ds_verifyCertification :: VerifyCertification+ } ++instance Storable IDirectSound8Vtbl where+ alignment = undefined+ sizeOf = undefined+ poke = undefined+ peek p = do+ let k = sizeOf (undefined :: FunPtr (IO ()))+ q <- return p;+ qif <- peek (castPtr q) ; q <- return (q `plusPtr` k) + arf <- peek (castPtr q) ; q <- return (q `plusPtr` k) + rel <- peek (castPtr q) ; q <- return (q `plusPtr` k) + csb <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gcp <- peek (castPtr q) ; q <- return (q `plusPtr` k) + dsb <- peek (castPtr q) ; q <- return (q `plusPtr` k) + scl <- peek (castPtr q) ; q <- return (q `plusPtr` k) + cpt <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gsc <- peek (castPtr q) ; q <- return (q `plusPtr` k) + ssc <- peek (castPtr q) ; q <- return (q `plusPtr` k) + ini <- peek (castPtr q) ; q <- return (q `plusPtr` k) + vcf <- peek (castPtr q) ; q <- return (q `plusPtr` k) + return $ + IDirectSound8Vtbl+ qif arf rel csb gcp dsb scl cpt gsc ssc ini vcf++mkDirectSound8 :: Ptr IDirectSound8 -> HWND -> IO DirectSound+mkDirectSound8 ids8 hwnd = do+ pvtbl <- liftM unIDirectSound8 $ peek ids8+ vtbl <- peek pvtbl+ let qif = mkDSQueryInterfaceMethod (ids8_QueryInterface vtbl)+ arf = mkDSAddRefMethod (ids8_AddRef vtbl)+ rel = mkDSReleaseMethod (ids8_Release vtbl)+ --+ csb = mkCreateSoundBufferMethod (ids8_CreateSoundBuffer vtbl)+ gcp = mkDSGetCapsMethod (ids8_GetCaps vtbl)+ dsb = mkDuplicateSoundBufferMethod (ids8_DuplicateSoundBuffer vtbl)+ scl = mkSetCooperativeLevelMethod (ids8_SetCooperativeLevel vtbl)+ cpt = mkCompactMethod (ids8_Compact vtbl)+ gsc = mkGetSpeakerConfigMethod (ids8_GetSpeakerConfig vtbl)+ ssc = mkSetSpeakerConfigMethod (ids8_SetSpeakerConfig vtbl)+ ini = mkDSInitializeMethod (ids8_Initialize vtbl)+ --+ vcf = mkVerifyCertificationMethod (ids8_VerifyCertification vtbl)+ return $ + DirectSound8 ids8 hwnd+ (qif ids8) (arf ids8) (rel ids8) (csb ids8)+ (gcp ids8) (dsb ids8) (scl ids8) (cpt ids8)+ (gsc ids8) (ssc ids8) (ini ids8) (vcf ids8)+ +foreign import stdcall "dynamic" mkDSQueryInterfaceMethod :: FunPtr (DS8Method QueryInterface) -> DS8Method QueryInterface+foreign import stdcall "dynamic" mkDSAddRefMethod :: FunPtr (DS8Method AddRef) -> DS8Method AddRef+foreign import stdcall "dynamic" mkDSReleaseMethod :: FunPtr (DS8Method Release) -> DS8Method Release++foreign import stdcall "dynamic" mkCreateSoundBufferMethod :: FunPtr (DS8Method CreateSoundBuffer) -> DS8Method CreateSoundBuffer+foreign import stdcall "dynamic" mkDSGetCapsMethod :: FunPtr (DS8Method DSGetCaps) -> DS8Method DSGetCaps+foreign import stdcall "dynamic" mkDuplicateSoundBufferMethod :: FunPtr (DS8Method DuplicateSoundBuffer) -> DS8Method DuplicateSoundBuffer+foreign import stdcall "dynamic" mkSetCooperativeLevelMethod :: FunPtr (DS8Method SetCooperativeLevel) -> DS8Method SetCooperativeLevel+foreign import stdcall "dynamic" mkCompactMethod :: FunPtr (DS8Method Compact) -> DS8Method Compact+foreign import stdcall "dynamic" mkGetSpeakerConfigMethod :: FunPtr (DS8Method GetSpeakerConfig) -> DS8Method GetSpeakerConfig+foreign import stdcall "dynamic" mkSetSpeakerConfigMethod :: FunPtr (DS8Method SetSpeakerConfig) -> DS8Method SetSpeakerConfig+foreign import stdcall "dynamic" mkDSInitializeMethod :: FunPtr (DS8Method DSInitialize) -> DS8Method DSInitialize+foreign import stdcall "dynamic" mkVerifyCertificationMethod :: FunPtr (DS8Method VerifyCertification) -> DS8Method VerifyCertification++-------------------------------------------------------------------------------++foreign import stdcall safe "DSound.h DirectSoundCreate8" c_DirectSoundCreate8 + :: Ptr GUID -> Ptr (Ptr IDirectSound8) -> Ptr () -> IO HRESULT++setCooperativeLevel :: DirectSound -> CooperativeLevel -> IO ()+setCooperativeLevel ds level = do+ ds_setCooperativeLevel ds (ds_windowHandle ds) (marshalCooperativeLevel level)+ return ()+ +directSoundCreate :: Maybe Driver -> HWND -> IO (Either String DirectSound)+directSoundCreate mdriver hwnd = do+ let mguid = join $ liftM drv_guid mdriver+ withMaybe mguid $ \guid -> + alloca $ \p -> do + hr <- c_DirectSoundCreate8 guid p nullPtr+ if hr == 0+ then do+ q <- peek p+ ds <- mkDirectSound8 q hwnd+ setCooperativeLevel ds CoopPriority -- according to the MSDN, we should call this immediately+ return (Right ds)+ else return $ Left "error creating the DirectSound object"+ +-------------------------------------------------------------------------------++-- the default device has no GUID+data Driver = Driver + { drv_guid :: Maybe GUID+ , drv_desc :: String+ , drv_module :: String+ } + deriving Show+ +type DSEnumCallbackW a = Ptr GUID -> CWString -> CWString -> Ptr a -> IO Bool+type DSEnumCallbackA a = Ptr GUID -> CString -> CString -> Ptr a -> IO Bool++foreign import stdcall unsafe "wrapper"+ mkDSEnumCallbackW :: DSEnumCallbackW () -> IO (FunPtr (DSEnumCallbackW ()))+ +foreign import stdcall safe "DSound.h DirectSoundEnumerateW" c_DirectSoundEnumerateW + :: FunPtr (DSEnumCallbackW a) -> Ptr a -> IO HRESULT++enumCallbackW :: DSEnumCallbackW ()+enumCallbackW pguid pdesc pdriver paccum = + do+ accum <- deRefStablePtr (castPtrToStablePtr paccum) :: IO (MVar [Driver])+ guid <- peekMaybe pguid+ desc <- peekCWString pdesc+ driver <- peekCWString pdriver+ adjustMVar accum (Driver guid desc driver :) + return True+ where+ adjustMVar :: MVar a -> (a -> a) -> IO ()+ adjustMVar m f = takeMVar m >>= \x -> putMVar m (f x)++ +enumerateDrivers :: IO [Driver]+enumerateDrivers = do+ accum <- newMVar [] :: IO (MVar [Driver]) + spaccum <- newStablePtr accum+ cb <- mkDSEnumCallbackW enumCallbackW+ c_DirectSoundEnumerateW cb (castStablePtrToPtr spaccum)+ freeStablePtr spaccum+ liftM reverse $ takeMVar accum+ +------------------------------------------------------------------------------- ++type SB8Method fun = Method ISoundBuffer8 fun++-- IDirectSoundBuffer methods+type SBGetCaps = Ptr DSBufferCaps -> IO HRESULT+type GetCurrentPosition = Ptr DWORD -> Ptr DWORD -> IO HRESULT+type GetFormat = Ptr WaveFormatX -> DWORD -> Ptr DWORD -> IO HRESULT+type GetVolume = Ptr LONG -> IO HRESULT+type GetPan = Ptr LONG -> IO HRESULT+type GetFrequency = Ptr DWORD -> IO HRESULT+type GetStatus = Ptr DWORD -> IO HRESULT+type SBInitialize = Ptr IDirectSound8 -> Ptr DSBufferDesc -> IO HRESULT+type SBLock = DWORD -> DWORD -> Ptr (Ptr ()) -> Ptr DWORD -> Ptr (Ptr ()) -> Ptr DWORD -> DWORD -> IO HRESULT+type SBPlay = DWORD -> DWORD -> DWORD -> IO HRESULT+type SetCurrentPosition = DWORD -> IO HRESULT+type SetFormat = Ptr WaveFormatX -> IO HRESULT+type SetVolume = LONG -> IO HRESULT+type SetPan = LONG -> IO HRESULT+type SetFrequency = DWORD -> IO HRESULT+type SBStop = IO HRESULT+type SBUnlock = Ptr () -> DWORD -> Ptr () -> DWORD -> IO HRESULT+type SBRestore = IO HRESULT+-- IDirectSoundBuffer8 methods+type SetFX = DWORD -> Ptr DSFXDesc -> Ptr DWORD -> IO HRESULT+type AcquireResources = DWORD -> DWORD -> Ptr DWORD -> IO HRESULT+type GetObjectInPath = RefGUID -> DWORD -> RefGUID -> Ptr (Ptr ()) -> IO HRESULT++{-+DECLARE_INTERFACE_(IDirectSoundBuffer8, IDirectSoundBuffer)+{+ // IUnknown methods+ STDMETHOD(QueryInterface) (THIS_ REFIID, LPVOID *) PURE;+ STDMETHOD_(ULONG,AddRef) (THIS) PURE;+ STDMETHOD_(ULONG,Release) (THIS) PURE;++ // IDirectSoundBuffer methods+ STDMETHOD(GetCaps) (THIS_ LPDSBCAPS pDSBufferCaps) PURE;+ STDMETHOD(GetCurrentPosition) (THIS_ LPDWORD pdwCurrentPlayCursor, LPDWORD pdwCurrentWriteCursor) PURE;+ STDMETHOD(GetFormat) (THIS_ LPWAVEFORMATEX pwfxFormat, DWORD dwSizeAllocated, LPDWORD pdwSizeWritten) PURE;+ STDMETHOD(GetVolume) (THIS_ LPLONG plVolume) PURE;+ STDMETHOD(GetPan) (THIS_ LPLONG plPan) PURE;+ STDMETHOD(GetFrequency) (THIS_ LPDWORD pdwFrequency) PURE;+ STDMETHOD(GetStatus) (THIS_ LPDWORD pdwStatus) PURE;+ STDMETHOD(Initialize) (THIS_ LPDIRECTSOUND pDirectSound, LPCDSBUFFERDESC pcDSBufferDesc) PURE;+ STDMETHOD(Lock) (THIS_ DWORD dwOffset, DWORD dwBytes, LPVOID *ppvAudioPtr1, LPDWORD pdwAudioBytes1,+ LPVOID *ppvAudioPtr2, LPDWORD pdwAudioBytes2, DWORD dwFlags) PURE;+ STDMETHOD(Play) (THIS_ DWORD dwReserved1, DWORD dwPriority, DWORD dwFlags) PURE;+ STDMETHOD(SetCurrentPosition) (THIS_ DWORD dwNewPosition) PURE;+ STDMETHOD(SetFormat) (THIS_ LPCWAVEFORMATEX pcfxFormat) PURE;+ STDMETHOD(SetVolume) (THIS_ LONG lVolume) PURE;+ STDMETHOD(SetPan) (THIS_ LONG lPan) PURE;+ STDMETHOD(SetFrequency) (THIS_ DWORD dwFrequency) PURE;+ STDMETHOD(Stop) (THIS) PURE;+ STDMETHOD(Unlock) (THIS_ LPVOID pvAudioPtr1, DWORD dwAudioBytes1, LPVOID pvAudioPtr2, DWORD dwAudioBytes2) PURE;+ STDMETHOD(Restore) (THIS) PURE;++ // IDirectSoundBuffer8 methods+ STDMETHOD(SetFX) (THIS_ DWORD dwEffectsCount, LPDSEFFECTDESC pDSFXDesc, LPDWORD pdwResultCodes) PURE;+ STDMETHOD(AcquireResources) (THIS_ DWORD dwFlags, DWORD dwEffectsCount, LPDWORD pdwResultCodes) PURE;+ STDMETHOD(GetObjectInPath) (THIS_ REFGUID rguidObject, DWORD dwIndex, REFGUID rguidInterface, LPVOID *ppObject) PURE;+};+-}++newtype ISoundBuffer8 = ISoundBuffer8 { unISoundBuffer8 :: Ptr ISoundBuffer8Vtbl } deriving Storable++data ISoundBuffer8Vtbl = ISoundBuffer8Vtbl+ { -- IUnknown methods+ isb8_QueryInterface :: FunPtr ( Ptr ISoundBuffer8 -> QueryInterface )+ , isb8_AddRef :: FunPtr ( Ptr ISoundBuffer8 -> AddRef )+ , isb8_Release :: FunPtr ( Ptr ISoundBuffer8 -> Release )+ -- IDirectSoundBuffer methods+ , isb8_GetCaps :: FunPtr ( Ptr ISoundBuffer8 -> SBGetCaps )+ , isb8_GetCurrentPosition :: FunPtr ( Ptr ISoundBuffer8 -> GetCurrentPosition )+ , isb8_GetFormat :: FunPtr ( Ptr ISoundBuffer8 -> GetFormat )+ , isb8_GetVolume :: FunPtr ( Ptr ISoundBuffer8 -> GetVolume )+ , isb8_GetPan :: FunPtr ( Ptr ISoundBuffer8 -> GetPan )+ , isb8_GetFrequency :: FunPtr ( Ptr ISoundBuffer8 -> GetFrequency )+ , isb8_GetStatus :: FunPtr ( Ptr ISoundBuffer8 -> GetStatus )+ , isb8_Initialize :: FunPtr ( Ptr ISoundBuffer8 -> SBInitialize )+ , isb8_Lock :: FunPtr ( Ptr ISoundBuffer8 -> SBLock )+ , isb8_Play :: FunPtr ( Ptr ISoundBuffer8 -> SBPlay )+ , isb8_SetCurrentPosition :: FunPtr ( Ptr ISoundBuffer8 -> SetCurrentPosition )+ , isb8_SetFormat :: FunPtr ( Ptr ISoundBuffer8 -> SetFormat )+ , isb8_SetVolume :: FunPtr ( Ptr ISoundBuffer8 -> SetVolume )+ , isb8_SetPan :: FunPtr ( Ptr ISoundBuffer8 -> SetPan )+ , isb8_SetFrequency :: FunPtr ( Ptr ISoundBuffer8 -> SetFrequency )+ , isb8_Stop :: FunPtr ( Ptr ISoundBuffer8 -> SBStop )+ , isb8_Unlock :: FunPtr ( Ptr ISoundBuffer8 -> SBUnlock )+ , isb8_Restore :: FunPtr ( Ptr ISoundBuffer8 -> SBRestore )+ -- IDirectSoundBuffer8 methods+ , isb8_SetFX :: FunPtr ( Ptr ISoundBuffer8 -> SetFX )+ , isb8_AcquireResources :: FunPtr ( Ptr ISoundBuffer8 -> AcquireResources )+ , isb8_GetObjectInPath :: FunPtr ( Ptr ISoundBuffer8 -> GetObjectInPath )+ }++-- "Address of a variable that receives the IDirectSoundBuffer interface of +-- the new buffer object. Use QueryInterface to obtain IDirectSoundBuffer8."+isb8_peekQueryInterface :: Ptr ISoundBuffer8 -> IO QueryInterface+isb8_peekQueryInterface pisb = do+ isb <- peek pisb+ pqif <- peek (castPtr $ unISoundBuffer8 isb) :: IO ( FunPtr ( Ptr ISoundBuffer8 -> QueryInterface ) )+ let qif = mkSBQueryInterface pqif :: Ptr ISoundBuffer8 -> QueryInterface + return (qif pisb)+ +instance Storable ISoundBuffer8Vtbl where+ alignment = undefined+ sizeOf = undefined+ poke = undefined+ peek p = do+ let k = sizeOf (undefined :: FunPtr (IO ()))+ q <- return p;+ qif <- peek (castPtr q) ; q <- return (q `plusPtr` k) + arf <- peek (castPtr q) ; q <- return (q `plusPtr` k) + rel <- peek (castPtr q) ; q <- return (q `plusPtr` k) + --+ cap <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gcp <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gft <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gvl <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gpn <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gfr <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gst <- peek (castPtr q) ; q <- return (q `plusPtr` k) + ini <- peek (castPtr q) ; q <- return (q `plusPtr` k) + lck <- peek (castPtr q) ; q <- return (q `plusPtr` k) + ply <- peek (castPtr q) ; q <- return (q `plusPtr` k) + scp <- peek (castPtr q) ; q <- return (q `plusPtr` k) + sft <- peek (castPtr q) ; q <- return (q `plusPtr` k) + svl <- peek (castPtr q) ; q <- return (q `plusPtr` k) + spn <- peek (castPtr q) ; q <- return (q `plusPtr` k) + sfr <- peek (castPtr q) ; q <- return (q `plusPtr` k) + stp <- peek (castPtr q) ; q <- return (q `plusPtr` k) + ulk <- peek (castPtr q) ; q <- return (q `plusPtr` k) + rst <- peek (castPtr q) ; q <- return (q `plusPtr` k) + --+ sfx <- peek (castPtr q) ; q <- return (q `plusPtr` k) + aqr <- peek (castPtr q) ; q <- return (q `plusPtr` k) + gop <- peek (castPtr q) ; q <- return (q `plusPtr` k) + return $ + ISoundBuffer8Vtbl+ qif arf rel + cap+ gcp gft gvl gpn gfr gst+ ini lck ply+ scp sft svl spn sfr+ stp ulk rst+ sfx aqr gop+ +foreign import stdcall "dynamic" mkSBQueryInterface :: FunPtr (SB8Method QueryInterface) -> SB8Method QueryInterface+foreign import stdcall "dynamic" mkSBAddRef :: FunPtr (SB8Method AddRef) -> SB8Method AddRef+foreign import stdcall "dynamic" mkSBRelease :: FunPtr (SB8Method Release) -> SB8Method Release++foreign import stdcall "dynamic" mkSBGetCaps :: FunPtr (SB8Method SBGetCaps) -> SB8Method SBGetCaps+foreign import stdcall "dynamic" mkGetCurrentPosition :: FunPtr (SB8Method GetCurrentPosition) -> SB8Method GetCurrentPosition+foreign import stdcall "dynamic" mkGetFormat :: FunPtr (SB8Method GetFormat) -> SB8Method GetFormat+foreign import stdcall "dynamic" mkGetVolume :: FunPtr (SB8Method GetVolume) -> SB8Method GetVolume+foreign import stdcall "dynamic" mkGetPan :: FunPtr (SB8Method GetPan) -> SB8Method GetPan+foreign import stdcall "dynamic" mkGetFrequency :: FunPtr (SB8Method GetFrequency) -> SB8Method GetFrequency +foreign import stdcall "dynamic" mkGetStatus :: FunPtr (SB8Method GetStatus) -> SB8Method GetStatus+foreign import stdcall "dynamic" mkSBInitialize :: FunPtr (SB8Method SBInitialize) -> SB8Method SBInitialize+foreign import stdcall "dynamic" mkSBLock :: FunPtr (SB8Method SBLock) -> SB8Method SBLock+foreign import stdcall "dynamic" mkSBPlay :: FunPtr (SB8Method SBPlay) -> SB8Method SBPlay +foreign import stdcall "dynamic" mkSetCurrentPosition :: FunPtr (SB8Method SetCurrentPosition) -> SB8Method SetCurrentPosition+foreign import stdcall "dynamic" mkSetFormat :: FunPtr (SB8Method SetFormat) -> SB8Method SetFormat+foreign import stdcall "dynamic" mkSetVolume :: FunPtr (SB8Method SetVolume) -> SB8Method SetVolume+foreign import stdcall "dynamic" mkSetPan :: FunPtr (SB8Method SetPan) -> SB8Method SetPan+foreign import stdcall "dynamic" mkSetFrequency :: FunPtr (SB8Method SetFrequency) -> SB8Method SetFrequency +foreign import stdcall "dynamic" mkSBStop :: FunPtr (SB8Method SBStop) -> SB8Method SBStop+foreign import stdcall "dynamic" mkSBUnlock :: FunPtr (SB8Method SBUnlock) -> SB8Method SBUnlock +foreign import stdcall "dynamic" mkSBRestore :: FunPtr (SB8Method SBRestore) -> SB8Method SBRestore++foreign import stdcall "dynamic" mkSetFX :: FunPtr (SB8Method SetFX) -> SB8Method SetFX+foreign import stdcall "dynamic" mkAcquireResources :: FunPtr (SB8Method AcquireResources) -> SB8Method AcquireResources+foreign import stdcall "dynamic" mkGetObjectInPath :: FunPtr (SB8Method GetObjectInPath) -> SB8Method GetObjectInPath++-- | the Haskell version of the @IDirectSoundBuffer8@ object+data SoundBuffer = SoundBuffer8+ { sb_soundBufer8object :: Ptr ISoundBuffer8+ , sb_waveFormatX :: WaveFormatX+ , sb_bufSizeInFrames :: Word32+ -- IUnknown methods+ , sb_queryInterface :: QueryInterface + , sb_addRef :: AddRef + , sb_release :: Release + -- IDirectSoundBuffer methods+ , sb_getCaps :: SBGetCaps + , sb_getCurrentPosition :: GetCurrentPosition + , sb_getFormat :: GetFormat + , sb_getVolume :: GetVolume + , sb_getPan :: GetPan + , sb_getFrequency :: GetFrequency + , sb_getStatus :: GetStatus + , sb_initialize :: SBInitialize + , sb_lock :: SBLock + , sb_play :: SBPlay + , sb_setCurrentPosition :: SetCurrentPosition + , sb_setFormat :: SetFormat + , sb_setVolume :: SetVolume + , sb_setPan :: SetPan + , sb_setFrequency :: SetFrequency + , sb_stop :: SBStop + , sb_unlock :: SBUnlock + , sb_restore :: SBRestore + -- IDirectSoundBuffer8 methods+ , sb_setFX :: SetFX+ , sb_acquireResources :: AcquireResources + , sb_getObjectInPath :: GetObjectInPath + }+ +mkSoundBuffer8 :: Ptr ISoundBuffer8 -> WaveFormatX -> Word32 -> IO SoundBuffer+mkSoundBuffer8 isb8 wfx bufsize = do+ pvtbl <- liftM unISoundBuffer8 $ peek isb8+ vtbl <- peek pvtbl+ let qif = mkSBQueryInterface (isb8_QueryInterface vtbl)+ arf = mkSBAddRef (isb8_AddRef vtbl)+ rel = mkSBRelease (isb8_Release vtbl)+ --+ cap = mkSBGetCaps (isb8_GetCaps vtbl)+ gcp = mkGetCurrentPosition (isb8_GetCurrentPosition vtbl) + gft = mkGetFormat (isb8_GetFormat vtbl)+ gvl = mkGetVolume (isb8_GetVolume vtbl)+ gpn = mkGetPan (isb8_GetPan vtbl)+ gfr = mkGetFrequency (isb8_GetFrequency vtbl) + gst = mkGetStatus (isb8_GetStatus vtbl) + ini = mkSBInitialize (isb8_Initialize vtbl)+ lck = mkSBLock (isb8_Lock vtbl)+ ply = mkSBPlay (isb8_Play vtbl) + scp = mkSetCurrentPosition (isb8_SetCurrentPosition vtbl) + sft = mkSetFormat (isb8_SetFormat vtbl)+ svl = mkSetVolume (isb8_SetVolume vtbl)+ spn = mkSetPan (isb8_SetPan vtbl)+ sfr = mkSetFrequency (isb8_SetFrequency vtbl) + stp = mkSBStop (isb8_Stop vtbl)+ ulk = mkSBUnlock (isb8_Unlock vtbl)+ rst = mkSBRestore (isb8_Restore vtbl)+ --+ sfx = mkSetFX (isb8_SetFX vtbl) + aqr = mkAcquireResources (isb8_AcquireResources vtbl) + gop = mkGetObjectInPath (isb8_GetObjectInPath vtbl) ++ return $ + SoundBuffer8 isb8 wfx bufsize+ (qif isb8) (arf isb8) (rel isb8) + (cap isb8)+ (gcp isb8) (gft isb8) (gvl isb8) (gpn isb8) (gfr isb8) (gst isb8)+ (ini isb8) (lck isb8) (ply isb8)+ (scp isb8) (sft isb8) (svl isb8) (spn isb8) (sfr isb8) + (stp isb8) (ulk isb8) (rst isb8)+ (sfx isb8) (aqr isb8) (gop isb8)++------------------------------------------------------------------------------- ++type SetNotificationPositions = DWORD -> Ptr DSBPositionNotify -> IO HRESULT ++newtype IDSNotify8 = IDSNotify8 { unIDSNotify8 :: Ptr IDSNotify8Vtbl } deriving Storable++data IDSNotify8Vtbl = IDSNotify8Vtbl+ { -- IUnknown methods+ idsn8_QueryInterface :: FunPtr ( Ptr IDSNotify8 -> QueryInterface )+ , idsn8_AddRef :: FunPtr ( Ptr IDSNotify8 -> AddRef )+ , idsn8_Release :: FunPtr ( Ptr IDSNotify8 -> Release )+ -- IDirectSoundNotify methods+ , idsn8_SetNotificationPositions :: FunPtr ( Ptr IDSNotify8 -> SetNotificationPositions )+ }+ +idsn8_peekSetNotificationPositions :: Ptr IDSNotify8 -> IO SetNotificationPositions+idsn8_peekSetNotificationPositions pidsn = do+ idsn <- peek pidsn+ let k = sizeOf (undefined :: FunPtr (IO ()))+ psnp <- peek (castPtr (unIDSNotify8 idsn) `plusPtr` (3*k)) :: IO ( FunPtr ( Ptr IDSNotify8 -> SetNotificationPositions) )+ let snp = mkSetNotificationPositions psnp+ return (snp pidsn)++foreign import stdcall "dynamic" mkSetNotificationPositions+ :: FunPtr (Ptr IDSNotify8 -> SetNotificationPositions) -> (Ptr IDSNotify8 -> SetNotificationPositions)+ +------------------------------------------------------------------------------- ++-- we assume here that we are on a low-endian architecture!!!+makeGUID :: Word32 -> Word16 -> Word16 -> [Word8] -> GUID+makeGUID data1 data2 data3 data4 = GUID chunk1 chunk2 where+ chunk1 = shiftL (fromIntegral data3 :: Word64) 48+ + shiftL (fromIntegral data2 :: Word64) 32+ + (fromIntegral data1 :: Word64)+ chunk2 = sum $ map f $ zip [0..7] data4+ f (i,b) = shiftL (fromIntegral b :: Word64) (i*8) + +iid_IDirectSoundBuffer8 :: GUID+iid_IDirectSoundBuffer8 = + makeGUID 0x6825a449 0x7524 0x4d82 [ 0x92, 0x0f, 0x50, 0xe3, 0x6a, 0xb3, 0xab, 0x1e ]+ -- DEFINE_GUID(IID_IDirectSoundBuffer8, 0x6825a449, 0x7524, 0x4d82, 0x92, 0x0f, 0x50, 0xe3, 0x6a, 0xb3, 0xab, 0x1e);+ -- chunk1 = 0x4d8275246825a449+ -- chunk2 = 0x1eabb36ae3500f92++iid_IDirectSoundNotify :: GUID+iid_IDirectSoundNotify = + makeGUID 0xb0210783 0x89cd 0x11d0 [ 0xaf, 0x08, 0x00, 0xa0, 0xc9, 0x25, 0xcd, 0x16 ]+ -- DEFINE_GUID(IID_IDirectSoundNotify, 0xb0210783, 0x89cd, 0x11d0, 0xaf, 0x8, 0x0, 0xa0, 0xc9, 0x25, 0xcd, 0x16); + +------------------------------------------------------------------------------- + +-- Buffer size is given in frames, not bytes!+-- The latency will be half of the buffer size when doublebuffering.+createSoundBuffer :: DirectSound -> WaveFormatX -> Int -> IO (Either String SoundBuffer)+createSoundBuffer ds wfx bufsize = do+ withSecondaryDSBufferDesc wfx bufsize $ \pdesc -> do+ alloca $ \q -> do+ hr <- ds_createSoundBuffer ds pdesc q nullPtr+ if hr==0 -- xx || hr==DS_NO_VIRTUALIZATION+ then do+ -- To obtain the interface, use the CreateSoundBuffer method to retrieve + -- IDirectSoundBuffer, and then pass IID_IDirectSoundBuffer8 to IDirectSoundBuffer::QueryInterface.+ isb <- peek q + qif <- isb8_peekQueryInterface isb+ isb8 <- with iid_IDirectSoundBuffer8 $ \iid -> + alloca $ \q -> do+ qif iid q+ liftM castPtr $ peek q+ sb <- mkSoundBuffer8 isb8 wfx (fromIntegral bufsize)+ return (Right sb)+ else + return $ Left "error creating the sound buffer"++sbQueryInterface :: SoundBuffer -> GUID -> IO (Ptr a)+sbQueryInterface sb guid = + with guid $ \iid -> alloca $ \p -> do+ sb_queryInterface sb iid p+ liftM castPtr $ peek p+ +getCurrentPlayWritePosition :: SoundBuffer -> IO (Word32,Word32)+getCurrentPlayWritePosition sb = do+ alloca $ \playcursor -> alloca $ \writecursor -> do+ sb_getCurrentPosition sb playcursor writecursor+ play <- peek playcursor + write <- peek writecursor+ return (play,write)+ +getCurrentPlayPosition :: SoundBuffer -> IO Word32+getCurrentPlayPosition sb = liftM fst $ getCurrentPlayWritePosition sb++getCurrentWritePosition :: SoundBuffer -> IO Word32+getCurrentWritePosition sb = liftM snd $ getCurrentPlayWritePosition sb++setCurrentPosition :: SoundBuffer -> Word32 -> IO ()+setCurrentPosition sb pos = do+ sb_setCurrentPosition sb pos+ return () + +dsblock_FromWriteCursor = 0x00000001 :: DWORD+dsblock_EntireBuffer = 0x00000002 :: DWORD+ +data Portion a = Portion !(Ptr a) !Word32 deriving Show++{- +-- locks at write position+withLockedBuffer1 :: SoundBuffer -> Int -> (Portion a -> Maybe (Portion a) -> IO b) -> IO b+withLockedBuffer1 sb nframes action = do+ let nbytes = nframes * (nBlockAlign $ sb_waveFormatX sb)+ flags = dsblock_FromWriteCursor+ alloca $ \pptr1 -> alloca $ \psiz1 -> alloca $ \pptr2 -> alloca $ \psiz2 -> do+ sb_lock sb 0 nbytes pptr1 psiz1 pptr2 psiz2 flags+ ptr1 <- peek pptr1+ siz1 <- peek psiz2+ let portion1 = Portion (castPtr ptr1) siz1+ ptr2 <- peek pptr2+ siz2 <- peek psiz2+ let portion2 = if ptr2 == nullPtr + then Nothing+ else Just (Portion (castPtr ptr2) siz2)+ action portion1 portion2+ sb_unlock sb ptr1 siz1 ptr2 siz2+-}++-- ofs / size in bytes!+withLockedBuffer :: SoundBuffer -> Word32 -> Word32 -> (Portion a -> Maybe (Portion a) -> IO b) -> IO b+withLockedBuffer sb ofs siz action = do+ alloca $ \pptr1 -> alloca $ \psiz1 -> alloca $ \pptr2 -> alloca $ \psiz2 -> do+ sb_lock sb ofs siz pptr1 psiz1 pptr2 psiz2 0+ ptr1 <- peek pptr1+ siz1 <- peek psiz1+ let portion1 = Portion (castPtr ptr1) siz1+ ptr2 <- peek pptr2+ siz2 <- peek psiz2+ let portion2 = if ptr2 == nullPtr + then Nothing+ else Just (Portion (castPtr ptr2) siz2)+ --print (ofs,siz,portion1,portion2) + res <- action portion1 portion2+ sb_unlock sb ptr1 siz1 ptr2 siz2+ return res++-------------------------------------------------------------------------------+ +data DSBPositionNotify = DSBPositionNotify + { pn_offset :: Word32+ , pn_event :: HANDLE+ }++instance Storable DSBPositionNotify where+ alignment _ = 4+ sizeOf _ = 4 + sizeOf (undefined :: HANDLE)+ peek = undefined+ poke p (DSBPositionNotify ofs event) = do+ poke (castPtr p) ofs+ poke (castPtr p `plusPtr` 4) event + +foreign import stdcall "windows.h CreateEventA" c_CreateEventA+ :: Ptr () -> BOOL -> BOOL -> CString -> IO HANDLE+ +-- ofs/siz in bytes!!+data DoubleBuffering = DoubleBuffering+ { db_ofs1 :: Word32 + , db_siz1 :: Word32+ , db_ev1 :: HANDLE+ , db_ofs2 :: Word32+ , db_siz2 :: Word32+ , db_ev2 :: HANDLE+ }+ deriving Show+ +closeDoubleBuffering :: DoubleBuffering -> IO ()+closeDoubleBuffering db = do+ closeHandle (db_ev1 db)+ closeHandle (db_ev2 db) + +-- | Sets up the sound buffer for double buffered continous playback +setupDoubleBuffering :: SoundBuffer -> IO DoubleBuffering+setupDoubleBuffering sb = do+ idsn <- sbQueryInterface sb iid_IDirectSoundNotify+ setNotificationPos <- idsn8_peekSetNotificationPositions idsn :: IO SetNotificationPositions+ let frame = fromIntegral (nBlockAlign $ sb_waveFormatX sb)+ bsize = (sb_bufSizeInFrames sb ) * frame+ half = (sb_bufSizeInFrames sb `div` 2) * frame+ evFirstHalf <- c_CreateEventA nullPtr False False nullPtr+ evSecondHalf <- c_CreateEventA nullPtr False False nullPtr + withArray + [ DSBPositionNotify 0 evFirstHalf+ , DSBPositionNotify half evSecondHalf+ ] $ \p -> setNotificationPos 2 p+ return $ DoubleBuffering + 0 half evFirstHalf + half (bsize-half) evSecondHalf ++foreign import stdcall unsafe {- this is needed so that we can terminate the playing thread???? -} "windows.h WaitForMultipleObjects" c_WaitForMultipleObjects+ :: DWORD -> Ptr HANDLE -> BOOL -> DWORD -> IO DWORD+ +-- | the second argument is number of frames, not bytes!+type FillBufferCallback a = Ptr a -> Word32 -> IO ()+ +dsbplay_Looping = 0x00000001 :: DWORD++-- | Forks a new lightweight thread. Returns the action for stopping the playback.+playWithDoubleBuffering :: SoundBuffer -> FillBufferCallback a -> IO (IO ())+playWithDoubleBuffering sb fillBuffer = do+ db <- setupDoubleBuffering sb+ let k = fromIntegral $ nBlockAlign (sb_waveFormatX sb) :: Word32+ let infinite = 0xFFFFFFFF :: Word32++{-+ print k+ print db+ putStrLn $ "sampling rate = " ++ show (nSamplesPerSec $ sb_waveFormatX sb)+-}++ threadID <- forkIO $ do + hr <- sb_play sb 0 0 dsbplay_Looping+ if (hr==0) + then do+ withArray [ db_ev1 db , db_ev2 db ] $ \evs -> forever $ do+ which <- c_WaitForMultipleObjects 2 evs False infinite+-- print which+ case which of+ 0 -> withLockedBuffer sb (db_ofs2 db) (db_siz2 db) $ \(Portion ptr nbytes) _ -> + fillBuffer ptr (nbytes `div` k)+ 1 -> withLockedBuffer sb (db_ofs1 db) (db_siz1 db) $ \(Portion ptr nbytes) _ -> + fillBuffer ptr (nbytes `div` k)+ _ -> return () -- should not happen + threadDelay 100 -- wait 100 microsec (so that the thread does not lock?)+ else do+ --closeDoubleBuffering db+ return ()+ + let + stop = do + sb_stop sb + killThread threadID+ closeDoubleBuffering db + + return stop + +-------------------------------------------------------------------------------+ +foreign import stdcall "windows.h GetConsoleTitleW" c_GetConsoleTitleW+ :: CWString -> DWORD -> IO DWORD++foreign import stdcall "windows.h SetConsoleTitleW" c_SetConsoleTitleW+ :: CWString -> IO BOOL+ +-- | see <http://support.microsoft.com/kb/124103>+getConsoleHWND_hack :: IO HWND+getConsoleHWND_hack = do+ allocaBytes (1024*2) $ \pbackup -> do+ c_GetConsoleTitleW pbackup 1023+ let unique = "microsoft-can-be-stupid-sometimes"+ withCWString unique $ \punique -> do+ c_SetConsoleTitleW punique+ threadDelay (42*1000)+ hwnd <- c_FindWindow nullPtr punique+ c_SetConsoleTitleW pbackup+ return hwnd++-------------------------------------------------------------------------------++{-+myCount = unsafePerformIO $ newMVar 0 :: MVar Double++myFillBuffer :: Ptr Int16 -> Word32 -> IO ()+myFillBuffer p n = do+ x <- takeMVar myCount+ --print n+ forM_ [0..n-1] $ \i -> pokeElemOff p (fromIntegral i) ( round $ 16000.0 * sin (x + 0.075 * fromIntegral i) ) + putMVar myCount (x + 0.075 * fromIntegral n)+ +main = do++ drvs <- enumerateDrivers+ mapM_ print drvs+ hwnd <- getConsoleHWND_hack+ print hwnd+ ds <- directSoundCreate (Just $ head drvs) hwnd >>= \mds -> case mds of+ Left err -> error err+ Right ds -> return ds+ sb <- createSoundBuffer ds mono44khzInt16 4096 >>= \msb -> case msb of+ Left err -> error err + Right sb -> return sb++ stop <- playWithDoubleBuffering sb myFillBuffer+ + getCurrentPlayPosition sb >>= print+ threadDelay (1*1000*1000)+ getCurrentPlayPosition sb >>= print+ threadDelay (1*1000*1000)+ getCurrentPlayPosition sb >>= print+ + alloca $ \p -> do+ sb_getFrequency sb p+ peek p >>= print+ + stop ++ threadDelay (2*1000*1000)+ + putStrLn "end"+-}
+ example/DirectSound_playback_example.hs view
@@ -0,0 +1,87 @@++module Main where++import Control.Monad+import Control.Concurrent++import Data.Maybe++import qualified Sound.Win32.DirectSound as DS++import Foreign++import System.IO+import System.IO.Unsafe as Unsafe++--------------------------------------------------------------------------------++sampleRate = 44100 :: Int+bufSize = 2048 :: Int -- in frames, not bytes+ +--------------------------------------------------------------------------------++frameCounter = Unsafe.unsafePerformIO (newMVar 0) :: MVar Word32++fillAudioBuffer :: Ptr Int16 -> Word32 -> IO ()+fillAudioBuffer buf nframes = do+ c <- readMVar frameCounter+ forM_ [0..nframes-1] $ \i -> do+ let k = fromIntegral (i+i) :: Int+ x = fromIntegral (c+i) / fromIntegral sampleRate :: Float+ y = sin ( x * 440.0 * 6.2830 + 100.0 * sin ( x*10.0) ) + a = round (y*20000) :: Int16+ pokeElemOff buf (k ) a -- left channel+ pokeElemOff buf (k+1) a -- right channel+ + swapMVar frameCounter (c+nframes)+ return () + +--------------------------------------------------------------------------------++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of + [(x,"")] -> Just x+ _ -> Nothing+ +select srclist getName = do+ names <- mapM getName srclist+ forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ 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+ +--------------------------------------------------------------------------------+ +main = do++ drvlist <- DS.enumerateDrivers+ drv <- case drvlist of+ [] -> error "no audio device found"+ [drv] -> return drv+ _ -> select 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+ 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++ stopAudio <- DS.playWithDoubleBuffering sb fillAudioBuffer+ -- threadDelay (20*1000*1000) -- 20 seconds+ putStrLn "\nplaying...\npress enter to exit"+ _ <- getLine + stopAudio