{-# language CPP #-}
{-# language DeriveGeneric #-}
{-# language DerivingStrategies #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language MagicHash #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UnboxedTuples #-}

-- | Types for dealing with the channels in audio samples
module Sound.Wave.Channels
  ( Monaural(..)
  , Stereo(..)
  , StereoWord8(..)
  , StereoInt16(..)
  , StereoInt32(..)
  , StereoFloat(..)
  , StereoDouble(..)
  ) where

import GHC.Exts
import GHC.Generics
import GHC.Word
import GHC.Int

import Data.Binary.Get
import Data.Binary.Put
import Data.Primitive

import Sound.Wave.Sample

-- | A single channel of audio. This will be represented with a boxed array, and
-- can be used to force basic types to have a boxed representation.
newtype Monaural a = Monaural { getMonaural :: a }
  deriving newtype (Eq, Ord, Show)
  deriving stock (Generic)

instance forall a. WaveSample a => WaveSample (Monaural a) where
  type SampleArr (Monaural a) = Array
  numChannels = numChannels @a
  bytesPerChannel = bytesPerChannel @a
  getSample = Monaural <$> getSample
  putSample (Monaural a) = putSample a

-- | Two channels of audio. Note that this will internally be represented as a
-- boxed array.
data Stereo a = Stereo
  { _stereoChan1 :: a
  , _stereoChan2 :: a
  }
  deriving stock (Eq, Ord, Show)
  deriving stock (Generic)

instance forall a. WaveSample a => WaveSample (Stereo a) where
  type SampleArr (Stereo a) = Array
  numChannels = 2 * numChannels @a
  bytesPerChannel = bytesPerChannel @a
  getSample = Stereo <$> getSample <*> getSample
  putSample (Stereo c1 c2) = putSample c1 <> putSample c2

--------------------------------------------------------------------------------

#define DERIVE_STEREO_PRIM(ty, el, elCons, ixArray, readArray, writeArray, indexAddr, readAddr, writeAddr) \
instance Prim (ty) where {                                              \
  sizeOf# _ = 2# *# sizeOf# (undefined :: el)                           \
; alignment# _ = alignment# (undefined :: el)                           \
; indexByteArray# ba# n# = (ty)                                         \
    (elCons (ixArray ba# (2# *# n#)))                                   \
    (elCons (ixArray ba# ((2# *# n#) +# 1#)))                           \
; readByteArray# mba# n# s1# =                                          \
    case readArray mba# (2# *# n#) s1# of                               \
      { (# s2#, f1# #) -> case readArray mba# ((2# *# n#) +# 1#) s2# of \
        { (# s3#, f2# #) -> (# s3#, ty (elCons f1#) (elCons f2#) #) }}  \
; writeByteArray# mba# n# (ty (elCons f1#) (elCons f2#)) s1# =          \
    case writeArray mba# (2# *# n#) f1# s1# of                          \
      { s2# -> writeArray mba# ((2# *# n#) +# 1#) f2# s2# }             \
; setByteArray# = defaultSetByteArray#                                  \
; indexOffAddr# a# n# =                                                 \
    case indexAddr a# (2# *# n#) of                                     \
      { f1# -> case indexAddr a# ((2# *# n#) +# 1#) of                  \
        { f2# -> ty (elCons f1#) (elCons f2#) }}                        \
; readOffAddr# a# n# s1# =                                              \
    case readAddr a# (2# *# n#) s1# of                                  \
      { (# s2#, f1# #) -> case readAddr a# ((2# *# n#) +# 1#) s2# of    \
        { (# s3#, f2# #) -> (# s3#, ty (elCons f1#) (elCons f2#) #) }}  \
; writeOffAddr# a# n# (ty (elCons f1#) (elCons f2#)) s1# =              \
    case writeAddr a# (2# *# n#) f1# s1# of                             \
      { s2# -> writeAddr a# ((2# *# n#) +# 1#) f2# s2# }                \
; setOffAddr# = defaultSetOffAddr#                                      \
; {-# INLINE sizeOf# #-}                                                \
; {-# INLINE alignment# #-}                                             \
; {-# INLINE indexByteArray# #-}                                        \
; {-# INLINE readByteArray# #-}                                         \
; {-# INLINE writeByteArray# #-}                                        \
; {-# INLINE setByteArray# #-}                                          \
; {-# INLINE indexOffAddr# #-}                                          \
; {-# INLINE readOffAddr# #-}                                           \
; {-# INLINE writeOffAddr# #-}                                          \
; {-# INLINE setOffAddr# #-}                                            \
}

--------------------------------------------------------------------------------

data StereoWord8 = StereoWord8
  { _stereoWord8Chan1 :: {-# UNPACK #-} !Word8
  , _stereoWord8Chan2 :: {-# UNPACK #-} !Word8
  }
  deriving stock (Eq, Ord, Show)
  deriving stock (Generic)

DERIVE_STEREO_PRIM(StereoWord8, Word8, W8#,
                   indexWord8Array#, readWord8Array#, writeWord8Array#,
                   indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#)

instance WaveSample StereoWord8 where
  type SampleArr StereoWord8 = PrimArray
  numChannels = 2
  bytesPerChannel = bytesPerChannel @Word8
  getSample = StereoWord8 <$> getWord8 <*> getWord8
  putSample (StereoWord8 c1 c2) = putWord8 c1 <> putWord8 c2

--------------------------------------------------------------------------------

data StereoInt16 = StereoInt16
  { _stereoInt16Chan1 :: {-# UNPACK #-} !Int16
  , _stereoInt16Chan2 :: {-# UNPACK #-} !Int16
  }
  deriving stock (Eq, Ord, Show)
  deriving stock (Generic)

DERIVE_STEREO_PRIM(StereoInt16, Int16, I16#,
                   indexInt16Array#, readInt16Array#, writeInt16Array#,
                   indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#)

instance WaveSample StereoInt16 where
  type SampleArr StereoInt16 = PrimArray
  numChannels = 2
  bytesPerChannel = bytesPerChannel @Int16
  getSample = StereoInt16 <$> getInt16le <*> getInt16le
  putSample (StereoInt16 c1 c2) = putInt16le c1 <> putInt16le c2

--------------------------------------------------------------------------------

data StereoInt32 = StereoInt32
  { _stereoInt32Chan1 :: {-# UNPACK #-} !Int32
  , _stereoInt32Chan2 :: {-# UNPACK #-} !Int32
  }
  deriving stock (Eq, Ord, Show)
  deriving stock (Generic)

DERIVE_STEREO_PRIM(StereoInt32, Int32, I32#,
                   indexInt32Array#, readInt32Array#, writeInt32Array#,
                   indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#)

instance WaveSample StereoInt32 where
  type SampleArr StereoInt32 = PrimArray
  numChannels = 2
  bytesPerChannel = bytesPerChannel @Int32
  getSample = StereoInt32 <$> getInt32le <*> getInt32le
  putSample (StereoInt32 c1 c2) = putInt32le c1 <> putInt32le c2

--------------------------------------------------------------------------------

data StereoFloat = StereoFloat
  { _stereoFloatChan1 :: {-# UNPACK #-} !Float
  , _stereoFloatChan2 :: {-# UNPACK #-} !Float
  }
  deriving stock (Eq, Ord, Show)
  deriving stock (Generic)

DERIVE_STEREO_PRIM(StereoFloat, Float, F#,
                   indexFloatArray#, readFloatArray#, writeFloatArray#,
                   indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#)

instance WaveSample StereoFloat where
  type SampleArr StereoFloat = PrimArray
  numChannels = 2
  bytesPerChannel = bytesPerChannel @Float
  getSample = StereoFloat <$> getFloatle <*> getFloatle
  putSample (StereoFloat c1 c2) = putFloatle c1 <> putFloatle c2

--------------------------------------------------------------------------------

data StereoDouble = StereoDouble
  { _stereoDoubleChan1 :: {-# UNPACK #-} !Double
  , _stereoDoubleChan2 :: {-# UNPACK #-} !Double
  }
  deriving stock (Eq, Ord, Show)
  deriving stock (Generic)

DERIVE_STEREO_PRIM(StereoDouble, Double, D#,
                   indexDoubleArray#, readDoubleArray#, writeDoubleArray#,
                   indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#)

instance WaveSample StereoDouble where
  type SampleArr StereoDouble = PrimArray
  numChannels = 2
  bytesPerChannel = bytesPerChannel @Double
  getSample = StereoDouble <$> getDoublele <*> getDoublele
  putSample (StereoDouble c1 c2) = putDoublele c1 <> putDoublele c2