diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/System/PortAudio.hs b/System/PortAudio.hs --- a/System/PortAudio.hs +++ b/System/PortAudio.hs @@ -152,9 +152,11 @@ newtype StreamFlags = StreamFlags CULong +instance Semigroup StreamFlags where + StreamFlags a <> StreamFlags b = StreamFlags (a .|. b) + instance Monoid StreamFlags where mempty = StreamFlags 0 - StreamFlags a `mappend` StreamFlags b = StreamFlags (a .|. b) clipOff :: StreamFlags clipOff = StreamFlags 0x00000001 @@ -168,23 +170,25 @@ primeOutputBuffersUsingStreamCallback :: StreamFlags primeOutputBuffersUsingStreamCallback = StreamFlags 0x00000008 -w :: IO CInt -> IO () -w n = do +wrap :: IO CInt -> IO () +wrap n = do r <- n unless (r == 0) $ throwIO $ fromErrorCode r withPortAudio :: IO a -> IO a -withPortAudio = bracket_ (w c'Pa_Initialize) (w c'Pa_Terminate) +withPortAudio = bracket_ (wrap c'Pa_Initialize) (wrap c'Pa_Terminate) data StreamCallbackResult = Continue | Complete | Abort deriving (Show, Eq, Ord, Enum) +instance Semigroup StreamCallbackResult where + Complete <> x = x + x <> Complete = x + Abort <> _ = Abort + _ <> Abort = Abort + Continue <> Continue = Continue + instance Monoid StreamCallbackResult where mempty = Complete - mappend Complete x = x - mappend x Complete = x - mappend Abort _ = Abort - mappend _ Abort = Abort - mappend Continue Continue = Continue data Status = Status { currentTime :: !Double @@ -208,9 +212,8 @@ withStream rate buf paramI paramO (StreamFlags flags) f m = withMaybe paramI $ \pin -> withMaybe paramO $ \pout -> do cb <- mk'PaStreamCallback $ callback f - let opener = do - ps <- malloc - w $ c'Pa_OpenStream ps + let opener ps = do + wrap $ c'Pa_OpenStream ps (castPtr pin) (castPtr pout) (CDouble rate) @@ -219,8 +222,8 @@ cb nullPtr peek ps - bracket opener (\s -> w (c'Pa_CloseStream s) >> free s) - $ \s -> bracket_ (w $ c'Pa_StartStream s) (w $ c'Pa_StopStream s) m + alloca $ \ps -> bracket (opener ps) (wrap . c'Pa_CloseStream) + $ \s -> bracket_ (wrap $ c'Pa_StartStream s) (wrap $ c'Pa_StopStream s) m data Closed = Closed diff --git a/bindings-portaudio.cabal b/bindings-portaudio.cabal --- a/bindings-portaudio.cabal +++ b/bindings-portaudio.cabal @@ -1,16 +1,16 @@ +cabal-version: 2.4 name: bindings-portaudio -version: 0.2 +version: 0.2.1 category: Sound author: Fumiaki Kinoshita maintainer: Fumiaki Kinoshita -license: BSD3 +license: BSD-3-Clause license-file: LICENSE synopsis: Low-level bindings to portaudio library description: -cabal-version: >= 1.10 build-type: Simple extra-source-files: @@ -26,6 +26,7 @@ extra.c LICENSE README.md + CHANGELOG.md example/*.hs example/example-portaudio.cabal example/LICENSE @@ -63,7 +64,7 @@ hsc2hs build-depends: - base < 5, bindings-DSL == 1.0.*, vector + base < 5, bindings-DSL ^>= 1.0, vector cc-options: -g diff --git a/example/example-portaudio.cabal b/example/example-portaudio.cabal --- a/example/example-portaudio.cabal +++ b/example/example-portaudio.cabal @@ -21,7 +21,7 @@ -- other-extensions: build-depends: base >=4.6 && < 5 , bindings-portaudio - , vector >= 0.10 && < 0.12 + , vector >= 0.10 && < 0.13 , linear -- hs-source-dirs: ghc-options: -threaded -Wall -O2 diff --git a/example/sine.hs b/example/sine.hs --- a/example/sine.hs +++ b/example/sine.hs @@ -1,51 +1,46 @@ -{-# LANGUAGE ViewPatterns, LambdaCase #-} -import System.PortAudio -import Control.Applicative -import Control.Concurrent -import Control.Monad -import Foreign.C.String -import Foreign.C.Types -import Foreign hiding (void) -import Linear (V2(..)) -import qualified Data.Vector as V -import qualified Data.Vector.Storable.Mutable as MV -import System.Environment -import System.Exit - -period :: Int -period = 128 - -table :: V.Vector Float -table = V.fromList [sin t | i <- [0..period - 1], let t = fromIntegral i / fromIntegral period * 2 * pi] - -callback :: MVar Int -> Status -> input -> MV.IOVector (V2 Float) -> IO StreamCallbackResult -callback phase _ _ o = do - i0 <- takeMVar phase - go i0 0 - putMVar phase $ i0 + n - return Continue - where - n = MV.length o - go :: Int -> Int -> IO () - go i0 i - | i == n = return () - | otherwise = do - let v = table V.! ((i0 + i) `mod` period) - MV.write o i (V2 v v) - go i0 (i + 1) - -main :: IO () -main = getArgs >>= \case - ((read -> rate) : (read -> buf) : _) -> withPortAudio $ do - (_, dev : _) <- getDevices - phase <- newMVar 0 - let output = streamParameters dev 0 - withStream rate buf noConnection output mempty (callback phase) - $ threadDelay $ 1000 * 1000 - _ -> usageExit - -usageExit :: IO () -usageExit = do - pname <- getProgName - putStrLn $ "\nUsage: " ++ pname ++ " \n" - exitSuccess +{-# LANGUAGE ViewPatterns, LambdaCase #-} +import System.PortAudio +import Control.Concurrent +import Linear (V2(..)) +import qualified Data.Vector as V +import qualified Data.Vector.Storable.Mutable as MV +import System.Environment +import System.Exit + +period :: Int +period = 128 + +table :: V.Vector Float +table = V.fromList [sin t | i <- [0..period - 1], let t = fromIntegral i / fromIntegral period * 2 * pi] + +callback :: MVar Int -> Status -> input -> MV.IOVector (V2 Float) -> IO StreamCallbackResult +callback phase _ _ o = do + i0 <- takeMVar phase + go i0 0 + putMVar phase $ i0 + n + return Continue + where + n = MV.length o + go :: Int -> Int -> IO () + go i0 i + | i == n = return () + | otherwise = do + let v = table V.! ((i0 + i) `mod` period) + MV.write o i (V2 v v) + go i0 (i + 1) + +main :: IO () +main = getArgs >>= \case + ((read -> rate) : (read -> buf) : _) -> withPortAudio $ do + (_, dev : _) <- getDevices + phase <- newMVar 0 + let output = streamParameters dev 0 + withStream rate buf noConnection output mempty (callback phase) + $ threadDelay $ 1000 * 1000 + _ -> usageExit + +usageExit :: IO () +usageExit = do + pname <- getProgName + putStrLn $ "\nUsage: " ++ pname ++ " \n" + exitSuccess