module Resource.Opus
  ( Config(..)
  , Source
  , load
  , loadPCM
  ) where

import RIO

import Foreign qualified
import Foreign.C.Types (CFloat(..))
import GHC.Stack (withFrozenCallStack)
import Sound.OpenAL qualified as OpenAL
import Sound.OpusFile qualified as OpusFile

import Resource.Source qualified as Resource

data Config = Config
  { Config -> Float
gain        :: Float
  , Config -> Bool
loopingMode :: Bool
  , Config -> Source
byteSource  :: Resource.Source
  }

type Source = (Double, OpenAL.Source)

load
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , HasCallStack
     )
  => OpenAL.Device
  -> Config
  -> m Source
load :: Device -> Config -> m Source
load Device
_device Config{Bool
Float
Source
byteSource :: Source
loopingMode :: Bool
gain :: Float
$sel:byteSource:Config :: Config -> Source
$sel:loopingMode:Config :: Config -> Bool
$sel:gain:Config :: Config -> Float
..} = do
  Pcm Int16
pcm <- (HasCallStack => m (Pcm Int16)) -> m (Pcm Int16)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (Pcm Int16)) -> m (Pcm Int16))
-> (HasCallStack => m (Pcm Int16)) -> m (Pcm Int16)
forall a b. (a -> b) -> a -> b
$
    (ByteString -> m (Pcm Int16)) -> Source -> m (Pcm Int16)
forall a (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, Typeable a,
 HasCallStack) =>
(ByteString -> m a) -> Source -> m a
Resource.load ByteString -> m (Pcm Int16)
forall (m :: * -> *). MonadIO m => ByteString -> m (Pcm Int16)
loadPCM Source
byteSource

  Format
alFormat <-
    case Pcm Int16 -> Either Int Channels
forall a. Pcm a -> Either Int Channels
OpusFile.pcmChannels Pcm Int16
pcm of
      Right Channels
OpusFile.Stereo ->
        Format -> m Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
OpenAL.Stereo16
      Right Channels
OpusFile.Mono ->
        Format -> m Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
OpenAL.Mono16
      Left Int
n -> do
        Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
          [ Utf8Builder
"unexpected channels in "
          , Source -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Source
byteSource
          , Utf8Builder
": "
          , Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Int
n
          ]
        m Format
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

  !Buffer
buffer <- IO Buffer -> m Buffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Buffer
forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
OpenAL.genObjectName
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ForeignPtr Int16 -> (Ptr Int16 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr (Pcm Int16 -> ForeignPtr Int16
forall a. Pcm a -> ForeignPtr a
OpusFile.pcmData Pcm Int16
pcm) \Ptr Int16
ptr -> do
      let
        mreg :: MemoryRegion Int16
mreg =
          Ptr Int16 -> ALsizei -> MemoryRegion Int16
forall a. Ptr a -> ALsizei -> MemoryRegion a
OpenAL.MemoryRegion Ptr Int16
ptr (Int -> ALsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ALsizei) -> Int -> ALsizei
forall a b. (a -> b) -> a -> b
$ Pcm Int16 -> Int
forall a. Pcm a -> Int
OpusFile.pcmSize Pcm Int16
pcm)
      Buffer -> StateVar (BufferData Int16)
forall a. Buffer -> StateVar (BufferData a)
OpenAL.bufferData Buffer
buffer StateVar (BufferData Int16) -> BufferData Int16 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
OpenAL.$=! MemoryRegion Int16 -> Format -> Float -> BufferData Int16
forall a. MemoryRegion a -> Format -> Float -> BufferData a
OpenAL.BufferData MemoryRegion Int16
mreg Format
alFormat Float
48000

  !Source
source <- IO Source -> m Source
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Source -> m Source) -> IO Source -> m Source
forall a b. (a -> b) -> a -> b
$ IO Source
forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
OpenAL.genObjectName
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    Source -> StateVar (Maybe Buffer)
OpenAL.buffer Source
source StateVar (Maybe Buffer) -> Maybe Buffer -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
OpenAL.$=! Buffer -> Maybe Buffer
forall a. a -> Maybe a
Just Buffer
buffer
    Source -> StateVar LoopingMode
OpenAL.loopingMode Source
source StateVar LoopingMode -> LoopingMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
OpenAL.$=! LoopingMode
loopingMode'
    Source -> StateVar Gain
OpenAL.sourceGain Source
source StateVar Gain -> Gain -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
OpenAL.$=! Gain
gain'
    Source -> StateVar Gain
OpenAL.rolloffFactor Source
source StateVar Gain -> Gain -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
OpenAL.$=! Gain
0 -- XXX: exempt from distance attenuation

  pure (Pcm Int16 -> Double
forall a. Pcm a -> Double
OpusFile.pcmTime Pcm Int16
pcm, Source
source)
  where
    loopingMode' :: LoopingMode
loopingMode' =
      if Bool
loopingMode then
        LoopingMode
OpenAL.Looping
      else
        LoopingMode
OpenAL.OneShot
    gain' :: Gain
gain' = Float -> Gain
CFloat Float
gain

-- TODO: extract to `opusfile`
loadPCM :: MonadIO m => ByteString -> m (OpusFile.Pcm Int16)
loadPCM :: ByteString -> m (Pcm Int16)
loadPCM ByteString
bytes = do
  !Handle
opusBytes <- IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$
    ByteString -> IO (Either Int Handle)
OpusFile.openMemoryBS ByteString
bytes IO (Either Int Handle)
-> (Either Int Handle -> IO Handle) -> IO Handle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Int
err ->
        String -> IO Handle
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> IO Handle) -> String -> IO Handle
forall a b. (a -> b) -> a -> b
$ String
"Opus loader error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
err
      Right Handle
res ->
        Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
res
  !Pcm Int16
pcmInt16 <- IO (Pcm Int16) -> m (Pcm Int16)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pcm Int16) -> m (Pcm Int16))
-> IO (Pcm Int16) -> m (Pcm Int16)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (Pcm Int16)
OpusFile.decodeInt16 Handle
opusBytes
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
OpusFile.free Handle
opusBytes
  pure Pcm Int16
pcmInt16