{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Synthesizer.LLVM.Storable.ChunkIterator where

import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector.Base as SVB

import Data.Word (Word32, )
import Foreign.Storable (Storable, poke, )
import Foreign.Ptr (FunPtr, Ptr, nullPtr, castPtr, )

import Control.Monad (liftM2, )

import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )
import Data.IORef (IORef, newIORef, readIORef, writeIORef, )


data T =
   forall a. Storable a =>
      Cons (IORef [SVB.Vector a]) (IORef (SVB.Vector a))

{-
I do not see a way,
how to bind the result type @Ptr a@
to the input type @SV.Vector a@.
We cannot make the element type of the storable vector
a type parameter of 'T'
since then we would also need to make Storable
a constraint of the FFI interface,
and this is forbidden.
-}
foreign import ccall "&nextChunk"
   nextCallBack ::
      FunPtr (
         StablePtr T ->
         Ptr Word32 -> IO (Ptr a)
      )

foreign export ccall "nextChunk"
   next ::
      StablePtr T ->
      Ptr Word32 -> IO (Ptr a)


new ::
   Storable a =>
   SVL.Vector a -> IO (StablePtr T)
new sig =
   newStablePtr =<<
   liftM2 Cons
      (newIORef (SVL.chunks sig))
      (newIORef
          (error "first chunk must be fetched with nextChunk"))

dispose ::
   StablePtr T -> IO ()
dispose = freeStablePtr

next ::
   StablePtr T ->
   Ptr Word32 -> IO (Ptr a)
next stable lenPtr =
   deRefStablePtr stable >>= \state ->
   case state of
      Cons listRef chunkRef -> do
         xt <- readIORef listRef
         case xt of
            [] -> return nullPtr
            (x:xs) ->
               {- We have to maintain a pointer to the current chunk
                  in order to protect it against garbage collection -}
               writeIORef chunkRef x >>
               writeIORef listRef xs >>
               SVB.withStartPtr x (\p l ->
                  poke lenPtr (fromIntegral l) >> return (castPtr p))