-- Copyright 2021 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Wrapper around PortAudio.  This only supports output.
module Util.Audio.PortAudio (
    initialize
    , play
    -- * Device
    , Device(..)
    , getDefaultOutput
    , getOutputDevices
    -- * Error
    , Error(..)
) where
import qualified Bindings.PortAudio as B
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans.Resource as Resource
import qualified Data.Vector.Storable as Vector
import qualified Foreign
import qualified Foreign.C as C
import           GHC.TypeLits (KnownNat)

import qualified Util.Audio.Audio as Audio

import           Global


initialize :: IO a -> IO a
initialize :: forall a. IO a -> IO a
initialize =
    forall a b c. IO a -> IO b -> IO c -> IO c
Exception.bracket_ (forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check IO CInt
B.c'Pa_Initialize) (forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check IO CInt
B.c'Pa_Terminate)

play :: forall rate chan. (KnownNat rate, KnownNat chan) => IO Bool
    -> Device -> Audio.AudioIO rate chan -> Resource.ResourceT IO ()
play :: forall (rate :: Nat) (chan :: Nat).
(KnownNat rate, KnownNat chan) =>
IO Bool -> Device -> AudioIO rate chan -> ResourceT IO ()
play IO Bool
pollQuit Device
device AudioIO rate chan
audio = do
    -- I could use bracket, but I'd need the one from 'exceptions'.
    (ReleaseKey
streamK, Ptr ()
stream) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
        (DeviceInfo -> IO (Ptr ())
open (Device -> DeviceInfo
_info Device
device)) (forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> IO CInt
B.c'Pa_CloseStream)
    (ReleaseKey
startK, ()
_) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
        (forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check forall a b. (a -> b) -> a -> b
$ Ptr () -> IO CInt
B.c'Pa_StartStream Ptr ()
stream)
        (\()
_ -> forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check forall a b. (a -> b) -> a -> b
$ Ptr () -> IO CInt
B.c'Pa_StopStream Ptr ()
stream)
    forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(MonadIO m, KnownNat chan) =>
IO Bool -> Ptr () -> Frames -> Audio m rate chan -> m ()
write IO Bool
pollQuit Ptr ()
stream Frames
framesPerBuffer AudioIO rate chan
audio
    forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release ReleaseKey
startK
    forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release ReleaseKey
streamK
    where
    flags :: CULong
flags = CULong
0 -- paClipOff?
    framesPerBuffer :: Frames
framesPerBuffer = Frames
1024
    open :: DeviceInfo -> IO (Ptr ())
open DeviceInfo
devInfo = forall a b. Storable a => (Ptr a -> IO b) -> IO b
Foreign.alloca forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr ())
streamp ->
        forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Foreign.with (DeviceInfo -> C'PaStreamParameters
outputParams DeviceInfo
devInfo) forall a b. (a -> b) -> a -> b
$ \Ptr C'PaStreamParameters
outputParamsp -> do
            forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check forall a b. (a -> b) -> a -> b
$ Ptr (Ptr ())
-> Ptr C'PaStreamParameters
-> Ptr C'PaStreamParameters
-> CDouble
-> CULong
-> CULong
-> C'PaStreamCallback
-> Ptr ()
-> IO CInt
B.c'Pa_OpenStream
                Ptr (Ptr ())
streamp
                forall a. Ptr a
Foreign.nullPtr
                Ptr C'PaStreamParameters
outputParamsp
                (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rate)
                (forall a b. (Integral a, Num b) => a -> b
fromIntegral Frames
framesPerBuffer)
                CULong
flags
                -- No callback, use blocking API.  It's more convenient, and
                -- latency seems to be low enough.
                forall a. FunPtr a
Foreign.nullFunPtr
                forall a. Ptr a
Foreign.nullPtr
            forall a. Storable a => Ptr a -> IO a
Foreign.peek Ptr (Ptr ())
streamp
    outputParams :: DeviceInfo -> C'PaStreamParameters
outputParams DeviceInfo
devInfo = B.C'PaStreamParameters
        { c'PaStreamParameters'device :: CInt
c'PaStreamParameters'device = Device -> CInt
_id Device
device
        , c'PaStreamParameters'channelCount :: CInt
c'PaStreamParameters'channelCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
chan
        -- #define  paFloat32   ((PaSampleFormat) 0x00000001)
        , c'PaStreamParameters'sampleFormat :: CULong
c'PaStreamParameters'sampleFormat = CULong
1
        -- High latency since it's the blocking API.
        , c'PaStreamParameters'suggestedLatency :: CDouble
c'PaStreamParameters'suggestedLatency =
            DeviceInfo -> CDouble
B.c'PaDeviceInfo'defaultHighOutputLatency DeviceInfo
devInfo
        , c'PaStreamParameters'hostApiSpecificStreamInfo :: Ptr ()
c'PaStreamParameters'hostApiSpecificStreamInfo = forall a. Ptr a
Foreign.nullPtr
        }
    chan :: Int
chan = forall (n :: Nat). KnownNat n => Proxy n -> Int
Audio.natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy chan)
    rate :: Int
rate = forall (n :: Nat). KnownNat n => Proxy n -> Int
Audio.natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy rate)

write :: forall m rate chan. (MonadIO m, KnownNat chan)
    => IO Bool -> Foreign.Ptr B.C'PaStream -> Audio.Frames
    -> Audio.Audio m rate chan -> m ()
write :: forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(MonadIO m, KnownNat chan) =>
IO Bool -> Ptr () -> Frames -> Audio m rate chan -> m ()
write IO Bool
pollQuit Ptr ()
stream Frames
framesPerBuffer = forall {m :: * -> *} {chan :: Nat} {rate :: Nat}.
(MonadIO m, KnownNat chan) =>
Audio m rate chan -> m ()
go
    where
    go :: Audio m rate chan -> m ()
go Audio m rate chan
audio = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
pollQuit forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> do
            ([Block]
blocks, Audio m rate chan
audio) <- forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(Monad m, KnownNat chan) =>
Frames -> Audio m rate chan -> m ([Block], Audio m rate chan)
Audio.splitAt Frames
framesPerBuffer Audio m rate chan
audio
            if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
blocks then forall (m :: * -> *) a. Monad m => a -> m a
return () else do
                -- I could probably mapM_ writeVector, but this gives
                -- predictable interrupt time and is the size I promised
                -- Pa_OpenStream.
                let samples :: Vector Sample
samples = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Vector Sample]
Audio.blockSamples [Block]
blocks
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Vector Sample -> IO ()
writeVector Vector Sample
samples
                Audio m rate chan -> m ()
go Audio m rate chan
audio
    writeVector :: Vector Sample -> IO ()
writeVector Vector Sample
v = forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
Vector.unsafeWith Vector Sample
v forall a b. (a -> b) -> a -> b
$ \Ptr Sample
vp ->
        forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check forall a b. (a -> b) -> a -> b
$ Ptr () -> Ptr () -> CULong -> IO CInt
B.c'Pa_WriteStream Ptr ()
stream (forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr Sample
vp)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (chan :: Nat).
KnownNat chan =>
Proxy chan -> Vector Sample -> Frames
Audio.vectorFrames Proxy chan
chan Vector Sample
v))
    chan :: Proxy chan
chan = forall {k} (t :: k). Proxy t
Proxy :: Proxy chan

-- * Device

data Device = Device {
    Device -> String
_name :: String
    , Device -> CInt
_id :: C.CInt
    , Device -> DeviceInfo
_info :: B.C'PaDeviceInfo
    } deriving (Int -> Device -> ShowS
[Device] -> ShowS
Device -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Device] -> ShowS
$cshowList :: [Device] -> ShowS
show :: Device -> String
$cshow :: Device -> String
showsPrec :: Int -> Device -> ShowS
$cshowsPrec :: Int -> Device -> ShowS
Show)

isOutput :: Device -> Bool
isOutput :: Device -> Bool
isOutput = (forall a. Ord a => a -> a -> Bool
>CInt
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceInfo -> CInt
B.c'PaDeviceInfo'maxOutputChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. Device -> DeviceInfo
_info

type DeviceInfo = B.C'PaDeviceInfo

getDefaultOutput :: IO Device
getDefaultOutput :: IO Device
getDefaultOutput = CInt -> IO Device
getDevice forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CInt
B.c'Pa_GetDefaultOutputDevice

getOutputDevices:: IO [Device]
getOutputDevices :: IO [Device]
getOutputDevices= do
    CInt
count <- IO CInt
B.c'Pa_GetDeviceCount
    forall a. (a -> Bool) -> [a] -> [a]
filter Device -> Bool
isOutput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CInt -> IO Device
getDevice [CInt
0 .. CInt
count forall a. Num a => a -> a -> a
- CInt
1]

getDevice :: C.CInt -> IO Device
getDevice :: CInt -> IO Device
getDevice CInt
id = do
    DeviceInfo
info <- CInt -> IO DeviceInfo
getDeviceInfo CInt
id
    String
name <- CString -> IO String
C.peekCAString forall a b. (a -> b) -> a -> b
$ DeviceInfo -> CString
B.c'PaDeviceInfo'name DeviceInfo
info
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Device { _name :: String
_name = String
name, _id :: CInt
_id = CInt
id, _info :: DeviceInfo
_info = DeviceInfo
info }

getDeviceInfo :: C.CInt -> IO DeviceInfo
getDeviceInfo :: CInt -> IO DeviceInfo
getDeviceInfo = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e a. Exception e => e -> IO a
Exception.throwIO Error
InvalidDevice) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< CInt -> IO (Maybe DeviceInfo)
lookupDevice

lookupDevice :: C.CInt -> IO (Maybe DeviceInfo)
lookupDevice :: CInt -> IO (Maybe DeviceInfo)
lookupDevice CInt
deviceId =
    forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
Foreign.maybePeek forall a. Storable a => Ptr a -> IO a
Foreign.peek forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CInt -> IO (Ptr DeviceInfo)
B.c'Pa_GetDeviceInfo CInt
deviceId


-- * Error

check :: MonadIO m => IO C.CInt -> m ()
check :: forall (m :: * -> *). MonadIO m => IO CInt -> m ()
check IO CInt
action = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  CInt
err <- IO CInt
action
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CInt
err forall a. Eq a => a -> a -> Bool
== CInt
0) forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
Exception.throwIO forall a b. (a -> b) -> a -> b
$ CInt -> Error
fromErrorCode CInt
err

data Error = NotInitialized
    | UnanticipatedHostError
    | InvalidChannelCount
    | InvalidSampleRate
    | InvalidDevice
    | InvalidFlag
    | SampleFormatNotSupported
    | BadIODeviceCombination
    | InsufficientMemory
    | BufferTooBig
    | BufferTooSmall
    | NullCallback
    | BadStreamPtr
    | TimedOut
    | InternalError
    | DeviceUnavailable
    | IncompatibleHostApiSpecificStreamInfo
    | StreamIsStopped
    | StreamIsNotStopped
    | InputOverflowed
    | OutputUnderflowed
    | HostApiNotFound
    | InvalidHostApi
    | CanNotReadFromACallbackStream
    | CanNotWriteToACallbackStream
    | CanNotReadFromAnOutputOnlyStream
    | CanNotWriteToAnInputOnlyStream
    | IncompatibleStreamHostApi
    | BadBufferPtr
    deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show, Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Eq Error
Error -> Error -> Bool
Error -> Error -> Ordering
Error -> Error -> Error
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Error -> Error -> Error
$cmin :: Error -> Error -> Error
max :: Error -> Error -> Error
$cmax :: Error -> Error -> Error
>= :: Error -> Error -> Bool
$c>= :: Error -> Error -> Bool
> :: Error -> Error -> Bool
$c> :: Error -> Error -> Bool
<= :: Error -> Error -> Bool
$c<= :: Error -> Error -> Bool
< :: Error -> Error -> Bool
$c< :: Error -> Error -> Bool
compare :: Error -> Error -> Ordering
$ccompare :: Error -> Error -> Ordering
Ord, Int -> Error
Error -> Int
Error -> [Error]
Error -> Error
Error -> Error -> [Error]
Error -> Error -> Error -> [Error]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Error -> Error -> Error -> [Error]
$cenumFromThenTo :: Error -> Error -> Error -> [Error]
enumFromTo :: Error -> Error -> [Error]
$cenumFromTo :: Error -> Error -> [Error]
enumFromThen :: Error -> Error -> [Error]
$cenumFromThen :: Error -> Error -> [Error]
enumFrom :: Error -> [Error]
$cenumFrom :: Error -> [Error]
fromEnum :: Error -> Int
$cfromEnum :: Error -> Int
toEnum :: Int -> Error
$ctoEnum :: Int -> Error
pred :: Error -> Error
$cpred :: Error -> Error
succ :: Error -> Error
$csucc :: Error -> Error
Enum)

instance Exception.Exception Error

fromErrorCode :: C.CInt -> Error
fromErrorCode :: CInt -> Error
fromErrorCode CInt
n = forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n forall a. Num a => a -> a -> a
+ Int
10000)