{- (c) 2009 Balazs Komuves -} -- | 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 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" -}