{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

-- {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-- TODO Find out exact version of cabal? GHC? that have a problem with this

{- |
Provides several clocks to use for audio processing,
for realtime as well as for batch/file processing.
-}
module FRP.Rhine.Clock.Realtime.Audio (
  AudioClock (..),
  AudioRate (..),
  PureAudioClock (..),
  PureAudioClockF,
  pureAudioClockF,
)
where

-- base
import Data.Time.Clock
import GHC.Float (double2Float)
import GHC.TypeLits (KnownNat, Nat, natVal)

-- transformers
import Control.Monad.IO.Class

-- dunai
import Control.Monad.Trans.MSF.Except hiding (step)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy

-- | Rates at which audio signals are typically sampled.
data AudioRate
  = Hz44100
  | Hz48000
  | Hz96000

-- | Converts an 'AudioRate' to its corresponding rate as an 'Integral'.
rateToIntegral :: Integral a => AudioRate -> a
rateToIntegral :: forall a. Integral a => AudioRate -> a
rateToIntegral AudioRate
Hz44100 = a
44100
rateToIntegral AudioRate
Hz48000 = a
48000
rateToIntegral AudioRate
Hz96000 = a
96000

-- TODO Test extensively

{- |
A clock for audio analysis and synthesis.
It internally processes samples in buffers of size 'bufferSize',
(the programmer does not have to worry about this),
at a sample rate of 'rate'
(of type 'AudioRate').
Both these parameters are in the type signature,
so it is not possible to compose signals with different buffer sizes
or sample rates.

After processing a buffer, the clock will wait the remaining time
until the next buffer must be processed,
using system UTC time.
The tag of the clock specifies whether the attempt to finish the last buffer in real time was successful.
A value of 'Nothing' represents success,
a value of @Just double@ represents a lag of 'double' seconds.
-}
data AudioClock (rate :: AudioRate) (bufferSize :: Nat) = AudioClock

class AudioClockRate (rate :: AudioRate) where
  theRate :: AudioClock rate bufferSize -> AudioRate
  theRateIntegral :: Integral a => AudioClock rate bufferSize -> a
  theRateIntegral = forall a. Integral a => AudioRate -> a
rateToIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rate :: AudioRate) (bufferSize :: Nat).
AudioClockRate rate =>
AudioClock rate bufferSize -> AudioRate
theRate
  theRateNum :: Num a => AudioClock rate bufferSize -> a
  theRateNum = forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rate :: AudioRate) a (bufferSize :: Nat).
(AudioClockRate rate, Integral a) =>
AudioClock rate bufferSize -> a
theRateIntegral

instance AudioClockRate Hz44100 where
  theRate :: forall (bufferSize :: Nat).
AudioClock 'Hz44100 bufferSize -> AudioRate
theRate AudioClock 'Hz44100 bufferSize
_ = AudioRate
Hz44100

instance AudioClockRate Hz48000 where
  theRate :: forall (bufferSize :: Nat).
AudioClock 'Hz48000 bufferSize -> AudioRate
theRate AudioClock 'Hz48000 bufferSize
_ = AudioRate
Hz48000

instance AudioClockRate Hz96000 where
  theRate :: forall (bufferSize :: Nat).
AudioClock 'Hz96000 bufferSize -> AudioRate
theRate AudioClock 'Hz96000 bufferSize
_ = AudioRate
Hz96000

theBufferSize ::
  (KnownNat bufferSize, Integral a) =>
  AudioClock rate bufferSize ->
  a
theBufferSize :: forall (bufferSize :: Nat) a (rate :: AudioRate).
(KnownNat bufferSize, Integral a) =>
AudioClock rate bufferSize -> a
theBufferSize = forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal

instance
  (MonadIO m, KnownNat bufferSize, AudioClockRate rate) =>
  Clock m (AudioClock rate bufferSize)
  where
  type Time (AudioClock rate bufferSize) = UTCTime
  type Tag (AudioClock rate bufferSize) = Maybe Double

  initClock :: AudioClock rate bufferSize
-> RunningClockInit
     m
     (Time (AudioClock rate bufferSize))
     (Tag (AudioClock rate bufferSize))
initClock AudioClock rate bufferSize
audioClock = do
    let
      step :: DiffTime
step =
        Integer -> DiffTime
picosecondsToDiffTime forall a b. (a -> b) -> a -> b
$ -- The only sufficiently precise conversion function
          forall a b. (RealFrac a, Integral b) => a -> b
round (Double
10 forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
12 :: Integer) forall a. Fractional a => a -> a -> a
/ forall (rate :: AudioRate) a (bufferSize :: Nat).
(AudioClockRate rate, Num a) =>
AudioClock rate bufferSize -> a
theRateNum AudioClock rate bufferSize
audioClock :: Double)
      bufferSize :: Int
bufferSize = forall (bufferSize :: Nat) a (rate :: AudioRate).
(KnownNat bufferSize, Integral a) =>
AudioClock rate bufferSize -> a
theBufferSize AudioClock rate bufferSize
audioClock

      runningClock :: MonadIO m => UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)
      runningClock :: forall (m :: Type -> Type).
MonadIO m =>
UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)
runningClock UTCTime
initialTime Maybe Double
maybeWasLate = forall (m :: Type -> Type) a b.
Monad m =>
MSFExcept m a b Void -> MSF m a b
safely forall a b. (a -> b) -> a -> b
$ do
        UTCTime
bufferFullTime <- forall e (m :: Type -> Type) a b.
MSF (ExceptT e m) a b -> MSFExcept m a b e
try forall a b. (a -> b) -> a -> b
$ proc () -> do
          Int
n <- forall n (m :: Type -> Type) a. (Num n, Monad m) => MSF m a n
count -< ()
          let nextTime :: UTCTime
nextTime = (forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
step forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int)) NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
initialTime
          ()
_ <- forall (m :: Type -> Type) e.
Monad m =>
MSF (ExceptT e m) (Bool, e) ()
throwOn' -< (Int
n forall a. Ord a => a -> a -> Bool
>= Int
bufferSize, UTCTime
nextTime)
          forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (UTCTime
nextTime, if Int
n forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe Double
maybeWasLate else forall a. Maybe a
Nothing)
        UTCTime
currentTime <- forall (m :: Type -> Type) e a b.
Monad m =>
m e -> MSFExcept m a b e
once_ forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        let
          lateDiff :: Diff UTCTime
lateDiff = UTCTime
currentTime forall time. TimeDomain time => time -> time -> Diff time
`diffTime` UTCTime
bufferFullTime
          late :: Maybe Double
late = if Diff UTCTime
lateDiff forall a. Ord a => a -> a -> Bool
> Double
0 then forall a. a -> Maybe a
Just Diff UTCTime
lateDiff else forall a. Maybe a
Nothing
        forall (m :: Type -> Type) a b e.
Monad m =>
MSF m a b -> MSFExcept m a b e
safe forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type).
MonadIO m =>
UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)
runningClock UTCTime
bufferFullTime Maybe Double
late
    UTCTime
initialTime <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( forall (m :: Type -> Type).
MonadIO m =>
UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)
runningClock UTCTime
initialTime forall a. Maybe a
Nothing
      , UTCTime
initialTime
      )

instance GetClockProxy (AudioClock rate bufferSize)

{- |
A side-effect free clock for audio synthesis and analysis.
The sample rate is given by 'rate' (of type 'AudioRate').
Since this clock does not wait for the completion of buffers,
the producer or the consumer of the signal has the obligation to
synchronise the signal with the system clock, if realtime is desired.
Otherwise, the clock is also suitable e.g. for batch processing of audio files.
-}
data PureAudioClock (rate :: AudioRate) = PureAudioClock

class PureAudioClockRate (rate :: AudioRate) where
  thePureRate :: PureAudioClock rate -> AudioRate
  thePureRateIntegral :: Integral a => PureAudioClock rate -> a
  thePureRateIntegral = forall a. Integral a => AudioRate -> a
rateToIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rate :: AudioRate).
PureAudioClockRate rate =>
PureAudioClock rate -> AudioRate
thePureRate
  thePureRateNum :: Num a => PureAudioClock rate -> a
  thePureRateNum = forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rate :: AudioRate) a.
(PureAudioClockRate rate, Integral a) =>
PureAudioClock rate -> a
thePureRateIntegral

instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) where
  type Time (PureAudioClock rate) = Double
  type Tag (PureAudioClock rate) = ()

  initClock :: PureAudioClock rate
-> RunningClockInit
     m (Time (PureAudioClock rate)) (Tag (PureAudioClock rate))
initClock PureAudioClock rate
audioClock =
    forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall a b. a -> b -> a
const (Double
1 forall a. Fractional a => a -> a -> a
/ forall (rate :: AudioRate) a.
(PureAudioClockRate rate, Num a) =>
PureAudioClock rate -> a
thePureRateNum PureAudioClock rate
audioClock)) forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall v s (m :: Type -> Type).
(VectorSpace v s, Monad m) =>
MSF m v v
sumS forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall a b. a -> b -> a
const ())
      , Double
0
      )

instance GetClockProxy (PureAudioClock rate)

-- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float'.
type PureAudioClockF (rate :: AudioRate) = RescaledClock (PureAudioClock rate) Float

{- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float',
   using 'double2Float' to rescale.
-}
pureAudioClockF :: PureAudioClockF rate
pureAudioClockF :: forall (rate :: AudioRate). PureAudioClockF rate
pureAudioClockF =
  RescaledClock
    { unscaledClock :: PureAudioClock rate
unscaledClock = forall (rate :: AudioRate). PureAudioClock rate
PureAudioClock
    , rescale :: Rescaling (PureAudioClock rate) Float
rescale = Double -> Float
double2Float
    }