{-# LANGUAGE ForeignFunctionInterface #-}

module Sound.OpusFile
  ( Handle(..)
  , OggOpusFile
  , openMemoryBS
  , openMemory
  , free

  , Channels(..)
  , channelCount
  , pcmTotal

  , Pcm(..)
  , decodeInt16
  ) where

import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Int (Int16, Int64)
import Foreign (ForeignPtr, Ptr)
import Foreign.C.Types (CChar, CInt(..))
import System.IO.Unsafe (unsafePerformIO)

import qualified Foreign

-- * Loading

newtype Handle = Handle (Ptr OggOpusFile)
  deriving (Handle -> Handle -> Bool
(Handle -> Handle -> Bool)
-> (Handle -> Handle -> Bool) -> Eq Handle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Handle -> Handle -> Bool
$c/= :: Handle -> Handle -> Bool
== :: Handle -> Handle -> Bool
$c== :: Handle -> Handle -> Bool
Eq, Int -> Handle -> ShowS
[Handle] -> ShowS
Handle -> String
(Int -> Handle -> ShowS)
-> (Handle -> String) -> ([Handle] -> ShowS) -> Show Handle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Handle] -> ShowS
$cshowList :: [Handle] -> ShowS
show :: Handle -> String
$cshow :: Handle -> String
showsPrec :: Int -> Handle -> ShowS
$cshowsPrec :: Int -> Handle -> ShowS
Show)

data OggOpusFile

openMemoryBS :: ByteString -> IO (Either Int Handle)
openMemoryBS :: ByteString -> IO (Either Int Handle)
openMemoryBS ByteString
bs = ByteString
-> (CStringLen -> IO (Either Int Handle)) -> IO (Either Int Handle)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs \(Ptr CChar
dataPtr, Int
dataLen) ->
  Ptr CChar -> CInt -> IO (Either Int Handle)
openMemory Ptr CChar
dataPtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dataLen)

openMemory :: Ptr CChar -> CInt -> IO (Either Int Handle)
openMemory :: Ptr CChar -> CInt -> IO (Either Int Handle)
openMemory Ptr CChar
dataPtr CInt
dataLen =
  (Ptr CInt -> IO (Either Int Handle)) -> IO (Either Int Handle)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
Foreign.alloca \Ptr CInt
errorPtr -> do
    Ptr OggOpusFile
oggOpusFile <- Ptr CChar -> CInt -> Ptr CInt -> IO (Ptr OggOpusFile)
op_test_memory Ptr CChar
dataPtr CInt
dataLen Ptr CInt
errorPtr
    Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
Foreign.peek Ptr CInt
errorPtr IO CInt
-> (CInt -> IO (Either Int Handle)) -> IO (Either Int Handle)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CInt
0 -> do
        Ptr OggOpusFile -> IO CInt
op_test_open Ptr OggOpusFile
oggOpusFile IO CInt
-> (CInt -> IO (Either Int Handle)) -> IO (Either Int Handle)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          CInt
0 ->
            Either Int Handle -> IO (Either Int Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Int Handle -> IO (Either Int Handle))
-> Either Int Handle -> IO (Either Int Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> Either Int Handle
forall a b. b -> Either a b
Right (Ptr OggOpusFile -> Handle
Handle Ptr OggOpusFile
oggOpusFile)
          CInt
err ->
            Either Int Handle -> IO (Either Int Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Int Handle -> IO (Either Int Handle))
-> Either Int Handle -> IO (Either Int Handle)
forall a b. (a -> b) -> a -> b
$ Int -> Either Int Handle
forall a b. a -> Either a b
Left (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
err)
      CInt
err ->
        Either Int Handle -> IO (Either Int Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Int Handle -> IO (Either Int Handle))
-> Either Int Handle -> IO (Either Int Handle)
forall a b. (a -> b) -> a -> b
$ Int -> Either Int Handle
forall a b. a -> Either a b
Left (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
err)

free :: Handle -> IO ()
free :: Handle -> IO ()
free (Handle Ptr OggOpusFile
handle) = Ptr OggOpusFile -> IO ()
op_free Ptr OggOpusFile
handle

-- * Information

data Channels
  = Mono
  | Stereo
  deriving (Channels -> Channels -> Bool
(Channels -> Channels -> Bool)
-> (Channels -> Channels -> Bool) -> Eq Channels
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Channels -> Channels -> Bool
$c/= :: Channels -> Channels -> Bool
== :: Channels -> Channels -> Bool
$c== :: Channels -> Channels -> Bool
Eq, Eq Channels
Eq Channels
-> (Channels -> Channels -> Ordering)
-> (Channels -> Channels -> Bool)
-> (Channels -> Channels -> Bool)
-> (Channels -> Channels -> Bool)
-> (Channels -> Channels -> Bool)
-> (Channels -> Channels -> Channels)
-> (Channels -> Channels -> Channels)
-> Ord Channels
Channels -> Channels -> Bool
Channels -> Channels -> Ordering
Channels -> Channels -> Channels
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 :: Channels -> Channels -> Channels
$cmin :: Channels -> Channels -> Channels
max :: Channels -> Channels -> Channels
$cmax :: Channels -> Channels -> Channels
>= :: Channels -> Channels -> Bool
$c>= :: Channels -> Channels -> Bool
> :: Channels -> Channels -> Bool
$c> :: Channels -> Channels -> Bool
<= :: Channels -> Channels -> Bool
$c<= :: Channels -> Channels -> Bool
< :: Channels -> Channels -> Bool
$c< :: Channels -> Channels -> Bool
compare :: Channels -> Channels -> Ordering
$ccompare :: Channels -> Channels -> Ordering
$cp1Ord :: Eq Channels
Ord, Int -> Channels -> ShowS
[Channels] -> ShowS
Channels -> String
(Int -> Channels -> ShowS)
-> (Channels -> String) -> ([Channels] -> ShowS) -> Show Channels
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Channels] -> ShowS
$cshowList :: [Channels] -> ShowS
show :: Channels -> String
$cshow :: Channels -> String
showsPrec :: Int -> Channels -> ShowS
$cshowsPrec :: Int -> Channels -> ShowS
Show, Int -> Channels
Channels -> Int
Channels -> [Channels]
Channels -> Channels
Channels -> Channels -> [Channels]
Channels -> Channels -> Channels -> [Channels]
(Channels -> Channels)
-> (Channels -> Channels)
-> (Int -> Channels)
-> (Channels -> Int)
-> (Channels -> [Channels])
-> (Channels -> Channels -> [Channels])
-> (Channels -> Channels -> [Channels])
-> (Channels -> Channels -> Channels -> [Channels])
-> Enum Channels
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 :: Channels -> Channels -> Channels -> [Channels]
$cenumFromThenTo :: Channels -> Channels -> Channels -> [Channels]
enumFromTo :: Channels -> Channels -> [Channels]
$cenumFromTo :: Channels -> Channels -> [Channels]
enumFromThen :: Channels -> Channels -> [Channels]
$cenumFromThen :: Channels -> Channels -> [Channels]
enumFrom :: Channels -> [Channels]
$cenumFrom :: Channels -> [Channels]
fromEnum :: Channels -> Int
$cfromEnum :: Channels -> Int
toEnum :: Int -> Channels
$ctoEnum :: Int -> Channels
pred :: Channels -> Channels
$cpred :: Channels -> Channels
succ :: Channels -> Channels
$csucc :: Channels -> Channels
Enum, Channels
Channels -> Channels -> Bounded Channels
forall a. a -> a -> Bounded a
maxBound :: Channels
$cmaxBound :: Channels
minBound :: Channels
$cminBound :: Channels
Bounded)

channelCount :: Handle -> Either Int Channels
channelCount :: Handle -> Either Int Channels
channelCount (Handle Ptr OggOpusFile
handle) =
  case IO CInt -> CInt
forall a. IO a -> a
unsafePerformIO (Ptr OggOpusFile -> CInt -> IO CInt
op_channel_count Ptr OggOpusFile
handle (-CInt
1)) of
    CInt
1 -> Channels -> Either Int Channels
forall a b. b -> Either a b
Right Channels
Mono
    CInt
2 -> Channels -> Either Int Channels
forall a b. b -> Either a b
Right Channels
Stereo
    CInt
n -> Int -> Either Int Channels
forall a b. a -> Either a b
Left (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)

pcmTotal :: Handle -> Either String Int
pcmTotal :: Handle -> Either String Int
pcmTotal (Handle Ptr OggOpusFile
handle) =
  let
    res :: Int64
res = IO Int64 -> Int64
forall a. IO a -> a
unsafePerformIO (Ptr OggOpusFile -> CInt -> IO Int64
op_pcm_total Ptr OggOpusFile
handle (-CInt
1))
  in
    if Int64
res Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0 then
      String -> Either String Int
forall a b. a -> Either a b
Left String
"OpusFile: The source is not seekable, _li wasn't less than the total number of links in the stream, or the stream was only partially open."
    else
      Int -> Either String Int
forall a b. b -> Either a b
Right (Int -> Either String Int) -> Int -> Either String Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
res

-- * Decoding

data Pcm a = Pcm
  { Pcm a -> ForeignPtr a
pcmData     :: ForeignPtr a
  , Pcm a -> Int
pcmSize     :: Int
  , Pcm a -> Double
pcmTime     :: Double
  , Pcm a -> Either Int Channels
pcmChannels :: Either Int Channels
  }
  deriving (Pcm a -> Pcm a -> Bool
(Pcm a -> Pcm a -> Bool) -> (Pcm a -> Pcm a -> Bool) -> Eq (Pcm a)
forall a. Pcm a -> Pcm a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pcm a -> Pcm a -> Bool
$c/= :: forall a. Pcm a -> Pcm a -> Bool
== :: Pcm a -> Pcm a -> Bool
$c== :: forall a. Pcm a -> Pcm a -> Bool
Eq, Int -> Pcm a -> ShowS
[Pcm a] -> ShowS
Pcm a -> String
(Int -> Pcm a -> ShowS)
-> (Pcm a -> String) -> ([Pcm a] -> ShowS) -> Show (Pcm a)
forall a. Int -> Pcm a -> ShowS
forall a. [Pcm a] -> ShowS
forall a. Pcm a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pcm a] -> ShowS
$cshowList :: forall a. [Pcm a] -> ShowS
show :: Pcm a -> String
$cshow :: forall a. Pcm a -> String
showsPrec :: Int -> Pcm a -> ShowS
$cshowsPrec :: forall a. Int -> Pcm a -> ShowS
Show)

decodeInt16 :: Handle -> IO (Pcm Int16)
decodeInt16 :: Handle -> IO (Pcm Int16)
decodeInt16 h :: Handle
h@(Handle Ptr OggOpusFile
handle) = do
  Int
hPcmSize <- case Handle -> Either String Int
pcmTotal Handle
h of
    Left String
err ->
      String -> IO Int
forall a. HasCallStack => String -> a
error String
err
    Right Int
res ->
      Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
res

  let
    byteSize :: Int
byteSize = Int
hPcmSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
numChannels Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleBytes

  ForeignPtr Int16
fptr <- Int -> IO (ForeignPtr Int16)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes Int
byteSize
  ForeignPtr Int16
-> (Ptr Int16 -> IO (Either CInt Int)) -> IO (Either CInt Int)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr Int16
fptr (Int -> Int -> Ptr Int16 -> IO (Either CInt Int)
go Int
hPcmSize Int
0) IO (Either CInt Int)
-> (Either CInt Int -> IO (Pcm Int16)) -> IO (Pcm Int16)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left CInt
ret ->
      String -> IO (Pcm Int16)
forall a. HasCallStack => String -> a
error (String -> IO (Pcm Int16)) -> String -> IO (Pcm Int16)
forall a b. (a -> b) -> a -> b
$ CInt -> String
forall a. Show a => a -> String
show CInt
ret
    Right Int
_samplesDone ->
      Pcm Int16 -> IO (Pcm Int16)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pcm :: forall a.
ForeignPtr a -> Int -> Double -> Either Int Channels -> Pcm a
Pcm
        { pcmData :: ForeignPtr Int16
pcmData     = ForeignPtr Int16
fptr
        , pcmSize :: Int
pcmSize     = Int
byteSize
        , pcmTime :: Double
pcmTime     = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hPcmSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
48000
        , pcmChannels :: Either Int Channels
pcmChannels = Either Int Channels
hPcmChannels
        }

  where
    hPcmChannels :: Either Int Channels
hPcmChannels = Handle -> Either Int Channels
channelCount Handle
h

    numChannels :: Int
numChannels = case Either Int Channels
hPcmChannels of
      Right Channels
Mono   -> Int
1
      Right Channels
Stereo -> Int
2
      Left Int
n       -> Int
n

    sampleBytes :: Int
sampleBytes = Int16 -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (Int16
forall a. HasCallStack => a
undefined :: Int16)

    go :: Int -> Int -> Ptr Int16 -> IO (Either CInt Int)
go Int
hPcmSize Int
samplesRead Ptr Int16
buf = do
      CInt
ret <- Ptr OggOpusFile -> Ptr Int16 -> CInt -> Ptr CInt -> IO CInt
op_read
        Ptr OggOpusFile
handle
        Ptr Int16
buf
        (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Int
hPcmSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
numChannels)
        Ptr CInt
forall a. Ptr a
Foreign.nullPtr
      if CInt
ret CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 then
        Either CInt Int -> IO (Either CInt Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CInt Int -> IO (Either CInt Int))
-> Either CInt Int -> IO (Either CInt Int)
forall a b. (a -> b) -> a -> b
$ CInt -> Either CInt Int
forall a b. a -> Either a b
Left CInt
ret
      else do
        let samplesDone :: Int
samplesDone = Int
samplesRead Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ret
        if Int
samplesDone Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
hPcmSize then
          Int -> Int -> Ptr Int16 -> IO (Either CInt Int)
go Int
hPcmSize Int
samplesDone (Ptr Int16 -> IO (Either CInt Int))
-> Ptr Int16 -> IO (Either CInt Int)
forall a b. (a -> b) -> a -> b
$
            Ptr Int16 -> Int -> Ptr Int16
forall a b. Ptr a -> Int -> Ptr b
Foreign.plusPtr Ptr Int16
buf (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ret Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
numChannels Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampleBytes)
        else
          Either CInt Int -> IO (Either CInt Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CInt Int -> IO (Either CInt Int))
-> Either CInt Int -> IO (Either CInt Int)
forall a b. (a -> b) -> a -> b
$ Int -> Either CInt Int
forall a b. b -> Either a b
Right Int
samplesDone

-- * FFI

foreign import ccall "op_free"
  op_free :: Ptr OggOpusFile -> IO ()

foreign import ccall "op_test_memory"
  op_test_memory :: Ptr CChar -> CInt -> Ptr CInt -> IO (Ptr OggOpusFile)

foreign import ccall "op_test_open"
  op_test_open :: Ptr OggOpusFile -> IO CInt

foreign import ccall "op_channel_count"
  op_channel_count :: Ptr OggOpusFile -> CInt -> IO CInt

foreign import ccall "op_pcm_total"
  op_pcm_total :: Ptr OggOpusFile -> CInt -> IO Int64

foreign import ccall "op_read"
  op_read
    :: Ptr OggOpusFile -- _of
    -> Ptr Int16       -- _pcm
    -> CInt            -- _buf_size
    -> Ptr CInt        -- _li
    -> IO CInt