{-# 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 Control.Arrow
import Data.Time.Clock
import GHC.Float (double2Float)
import GHC.TypeLits (KnownNat, Nat, natVal)

-- transformers
import Control.Monad.IO.Class

-- automaton
import Data.Automaton
import Data.Automaton.Trans.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 = AudioRate -> a
forall a. Integral a => AudioRate -> a
rateToIntegral (AudioRate -> a)
-> (AudioClock rate bufferSize -> AudioRate)
-> AudioClock rate bufferSize
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AudioClock rate bufferSize -> AudioRate
forall (bufferSize :: Nat). AudioClock rate bufferSize -> AudioRate
forall (rate :: AudioRate) (bufferSize :: Nat).
AudioClockRate rate =>
AudioClock rate bufferSize -> AudioRate
theRate
  theRateNum :: (Num a) => AudioClock rate bufferSize -> a
  theRateNum = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a)
-> (AudioClock rate bufferSize -> Integer)
-> AudioClock rate bufferSize
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AudioClock rate bufferSize -> Integer
forall a (bufferSize :: Nat).
Integral a =>
AudioClock rate bufferSize -> a
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 = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a)
-> (AudioClock rate bufferSize -> Integer)
-> AudioClock rate bufferSize
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AudioClock rate bufferSize -> Integer
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 (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$
          Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
10 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
12 :: Integer) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ AudioClock rate bufferSize -> Double
forall a (bufferSize :: Nat).
Num a =>
AudioClock rate bufferSize -> a
forall (rate :: AudioRate) a (bufferSize :: Nat).
(AudioClockRate rate, Num a) =>
AudioClock rate bufferSize -> a
theRateNum AudioClock rate bufferSize
audioClock :: Double) -- The only sufficiently precise conversion function
      bufferSize :: Int
bufferSize = AudioClock rate bufferSize -> Int
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 -> Automaton m () (UTCTime, Maybe Double)
      runningClock :: forall (m :: Type -> Type).
MonadIO m =>
UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
runningClock UTCTime
initialTime Maybe Double
maybeWasLate = AutomatonExcept () (UTCTime, Maybe Double) m Void
-> Automaton m () (UTCTime, Maybe Double)
forall (m :: Type -> Type) a b.
Monad m =>
AutomatonExcept a b m Void -> Automaton m a b
safely (AutomatonExcept () (UTCTime, Maybe Double) m Void
 -> Automaton m () (UTCTime, Maybe Double))
-> AutomatonExcept () (UTCTime, Maybe Double) m Void
-> Automaton m () (UTCTime, Maybe Double)
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
bufferFullTime <- Automaton (ExceptT UTCTime m) () (UTCTime, Maybe Double)
-> AutomatonExcept () (UTCTime, Maybe Double) m UTCTime
forall (m :: Type -> Type) e a b.
Monad m =>
Automaton (ExceptT e m) a b -> AutomatonExcept a b m e
try (Automaton (ExceptT UTCTime m) () (UTCTime, Maybe Double)
 -> AutomatonExcept () (UTCTime, Maybe Double) m UTCTime)
-> Automaton (ExceptT UTCTime m) () (UTCTime, Maybe Double)
-> AutomatonExcept () (UTCTime, Maybe Double) m UTCTime
forall a b. (a -> b) -> a -> b
$ proc () -> do
          Int
n <- Automaton (ExceptT UTCTime m) () Int
forall n (m :: Type -> Type) a. (Num n, Monad m) => Automaton m a n
count -< ()
          let nextTime :: UTCTime
nextTime = (DiffTime -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
step NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int)) NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
initialTime
          ()
_ <- Automaton (ExceptT UTCTime m) (Bool, UTCTime) ()
forall (m :: Type -> Type) e.
Monad m =>
Automaton (ExceptT e m) (Bool, e) ()
throwOn' -< (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bufferSize, UTCTime
nextTime)
          Automaton
  (ExceptT UTCTime m) (UTCTime, Maybe Double) (UTCTime, Maybe Double)
forall (a :: Type -> Type -> Type) b. Arrow a => a b b
returnA -< (UTCTime
nextTime, if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe Double
maybeWasLate else Maybe Double
forall a. Maybe a
Nothing)
        UTCTime
currentTime <- m UTCTime -> AutomatonExcept () (UTCTime, Maybe Double) m UTCTime
forall (m :: Type -> Type) e a b.
Monad m =>
m e -> AutomatonExcept a b m e
once_ (m UTCTime -> AutomatonExcept () (UTCTime, Maybe Double) m UTCTime)
-> m UTCTime
-> AutomatonExcept () (UTCTime, Maybe Double) m UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        let
          lateDiff :: Diff UTCTime
lateDiff = UTCTime
currentTime UTCTime -> UTCTime -> Diff UTCTime
forall time. TimeDomain time => time -> time -> Diff time
`diffTime` UTCTime
bufferFullTime
          late :: Maybe Double
late = if Double
Diff UTCTime
lateDiff Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then Double -> Maybe Double
forall a. a -> Maybe a
Just Double
Diff UTCTime
lateDiff else Maybe Double
forall a. Maybe a
Nothing
        Automaton m () (UTCTime, Maybe Double)
-> AutomatonExcept () (UTCTime, Maybe Double) m Void
forall (m :: Type -> Type) a b e.
Monad m =>
Automaton m a b -> AutomatonExcept a b m e
safe (Automaton m () (UTCTime, Maybe Double)
 -> AutomatonExcept () (UTCTime, Maybe Double) m Void)
-> Automaton m () (UTCTime, Maybe Double)
-> AutomatonExcept () (UTCTime, Maybe Double) m Void
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
forall (m :: Type -> Type).
MonadIO m =>
UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
runningClock UTCTime
bufferFullTime Maybe Double
late
    UTCTime
initialTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    (Automaton m () (UTCTime, Maybe Double), UTCTime)
-> m (Automaton m () (UTCTime, Maybe Double), UTCTime)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
forall (m :: Type -> Type).
MonadIO m =>
UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
runningClock UTCTime
initialTime Maybe Double
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 = AudioRate -> a
forall a. Integral a => AudioRate -> a
rateToIntegral (AudioRate -> a)
-> (PureAudioClock rate -> AudioRate) -> PureAudioClock rate -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureAudioClock rate -> AudioRate
forall (rate :: AudioRate).
PureAudioClockRate rate =>
PureAudioClock rate -> AudioRate
thePureRate
  thePureRateNum :: (Num a) => PureAudioClock rate -> a
  thePureRateNum = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a)
-> (PureAudioClock rate -> Integer) -> PureAudioClock rate -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureAudioClock rate -> Integer
forall a. Integral a => PureAudioClock rate -> a
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 =
    (Automaton m () (Double, ()), Double)
-> m (Automaton m () (Double, ()), Double)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( (() -> Double) -> Automaton m () Double
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (Double -> () -> Double
forall a b. a -> b -> a
const (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ PureAudioClock rate -> Double
forall a. Num a => PureAudioClock rate -> a
forall (rate :: AudioRate) a.
(PureAudioClockRate rate, Num a) =>
PureAudioClock rate -> a
thePureRateNum PureAudioClock rate
audioClock)) Automaton m () Double
-> Automaton m Double (Double, ()) -> Automaton m () (Double, ())
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Automaton m Double Double
forall (m :: Type -> Type) v s.
(Monad m, VectorSpace v s) =>
Automaton m v v
sumS Automaton m Double Double
-> Automaton m Double () -> Automaton m Double (Double, ())
forall b c c'.
Automaton m b c -> Automaton m b c' -> Automaton m b (c, c')
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Double -> ()) -> Automaton m Double ()
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> Double -> ()
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 = PureAudioClock rate
forall (rate :: AudioRate). PureAudioClock rate
PureAudioClock
    , rescale :: Rescaling (PureAudioClock rate) Float
rescale = Double -> Float
Rescaling (PureAudioClock rate) Float
double2Float
    }