{-# LANGUAGE TypeFamilies #-}
module Synthesizer.LLVM.RingBuffer where

import qualified LLVM.Extra.MaybeContinuation as Maybe
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Control as C
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as Class

import qualified LLVM.Core as LLVM
import LLVM.Core (CodeGenFunction, Value, )

import Data.Word (Word32, )
import Foreign.Storable.Tuple ()
import Foreign.Ptr (Ptr, )

import Prelude hiding (length, )


{-
I have chosen this type parameter
in order make sure that you can only retrieve from the buffer
what you have put into it.
E.g. if you store a SerialVector in it,
you can only load a SerialVector from it, but not a Vector,
although both of them use the same type for storage.
-}
data T a =
   Cons {
      buffer :: Value (Ptr (Memory.Struct a)),
      length :: Value Word32,
      current :: Value Word32,
      oldest_ :: Value Word32
   }

{- |
This function does not check for range violations.
If the ring buffer was generated by @track initial time@,
then the minimum index is zero and the maximum index is @time@.
Index zero refers to the current sample
and index @time@ refers to the oldest one.
-}
index ::
   (Memory.C a) =>
   Value Word32 -> T a -> CodeGenFunction r a
index i rb = do
   k <- flip A.irem (length rb) =<< A.add (current rb) i
   Memory.load =<< LLVM.getElementPtr (buffer rb) (k, ())

{- |
Fetch the oldest value in the ring buffer.
For the result of @track initial time@
this is equivalent to @index time@ but more efficient.
-}
oldest ::
   (Memory.C a) =>
   T a -> CodeGenFunction r a
oldest rb =
   Memory.load =<< LLVM.getElementPtr (buffer rb) (oldest_ rb, ())


trackConstCreate ::
   (p -> t) ->
   p -> IO ((), t)
trackConstCreate getTime p =
   return ((), getTime p)


trackNext ::
   (Memory.C al, Memory.Struct al ~ am) =>
   (tl -> Value Word32) ->
   (tl, Value (Ptr am)) -> () ->
   al -> Value Word32 ->
   Maybe.T r z (T al, Value Word32)
trackNext valueTime (size,ptr) () a remain0 = Maybe.lift $ do
   Memory.store a =<< LLVM.getElementPtr ptr (remain0, ())
   cont <- A.cmp LLVM.CmpGT remain0 A.zero
   let size0 = valueTime size
   remain1 <- C.ifThenSelect cont size0 (A.dec remain0)
   size1 <- A.inc size0
   return (Cons ptr size1 remain0 remain1, remain1)

trackStart ::
   (Memory.C al, Memory.Struct al ~ am) =>
   (tl -> Value Word32) ->
   (al, tl) ->
   CodeGenFunction r ((tl, Value (Ptr am)), Value Word32)
trackStart valueTime (initial, size) = do
   let size0 = valueTime size
   size1 <- A.inc size0
   ptr <- LLVM.arrayMalloc size1
   -- cf. LLVM.Storable.Signal.fill
   C.arrayLoop size1 ptr () $ \ ptri () ->
      Memory.store initial ptri
   return ((size,ptr), size0)

trackStop ::
   (LLVM.IsType am) =>
   (tl, Value (Ptr am)) ->
   Value Word32 ->
   CodeGenFunction r ()
trackStop (_size,ptr) _remain = LLVM.free ptr

trackCreate ::
   (Class.MakeValueTuple a, Class.ValueTuple a ~ al,
    Memory.C al, Memory.Struct al ~ am) =>
   (p -> a) ->
   (p -> t) ->
   p ->
   IO ((), (a, t))
trackCreate getInitial getTime p =
   return ((), (getInitial p, getTime p))

trackDelete :: () -> IO ()
trackDelete () = return ()