module Graphics.Luminance.Core.Buffer where
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.RWS ( RWS, ask, get, evalRWS, execRWS, put )
import Control.Monad.Trans.Resource ( MonadResource, register )
import Data.Bits ( (.|.) )
import Data.Foldable ( toList )
import Data.Word ( Word32 )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( peekArray, pokeArray )
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( Ptr, castPtr, nullPtr, plusPtr )
import Foreign.Storable ( Storable(..) )
import Graphics.GL
import Graphics.Luminance.Core.RW
newtype Buffer = Buffer { bufferID :: GLuint } deriving (Eq,Show)
mkBuffer :: (MonadIO m,MonadResource m)
=> GLbitfield
-> Int
-> m (Buffer,Ptr ())
mkBuffer flags size = do
(bid,mapped) <- liftIO . alloca $ \p -> do
glCreateBuffers 1 p
bid <- peek p
mapped <- createStorage bid flags size
pure (bid,mapped)
_ <- register . with bid $ glDeleteBuffers 1
pure (Buffer bid,mapped)
createStorage :: GLuint -> GLbitfield -> Int -> IO (Ptr ())
createStorage bid flags size = do
glNamedBufferStorage bid bytes nullPtr flags
ptr <- glMapNamedBufferRange bid 0 (fromIntegral size) flags
pure ptr
where
bytes = fromIntegral size
mkBufferWithRegions :: (MonadIO m,MonadResource m)
=> GLbitfield
-> BuildRegion rw a
-> m (a,Buffer)
mkBufferWithRegions flags buildRegions = do
(buffer,mapped) <- mkBuffer flags bytes
pure (fst $ evalRWS built (buffer,mapped) 0,buffer)
where
built = runBuildRegion buildRegions
(bytes,_) = execRWS built (Buffer 0,nullPtr) 0
class BufferRW rw where
bufferFlagsFromRW :: rw -> GLenum
instance BufferRW R where
bufferFlagsFromRW _ = GL_MAP_READ_BIT
instance BufferRW RW where
bufferFlagsFromRW _ = GL_MAP_READ_BIT .|. GL_MAP_WRITE_BIT
instance BufferRW W where
bufferFlagsFromRW _ = GL_MAP_WRITE_BIT
createBuffer :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m)
=> BuildRegion rw a
-> m a
createBuffer = fmap fst . mkBufferWithRegions (bufferFlagsFromRW (undefined :: rw) .|. GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT)
createBuffer_ :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m)
=> BuildRegion rw a
-> m (a,Buffer)
createBuffer_ = mkBufferWithRegions $
bufferFlagsFromRW (undefined :: rw) .|. GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT
data Region rw a = Region {
regionPtr :: Ptr a
, regionOffset :: Int
, regionSize :: Int
, regionBuffer :: Buffer
} deriving (Eq,Show)
newtype BuildRegion rw a = BuildRegion {
runBuildRegion :: RWS (Buffer,Ptr ()) () Int a
} deriving (Applicative,Functor,Monad)
newRegion :: forall rw a. (Storable a) => Word32 -> BuildRegion rw (Region rw a)
newRegion size = BuildRegion $ do
offset <- get
put $ offset + fromIntegral size * sizeOf (undefined :: a)
(buffer,ptr) <- ask
pure $ Region {
regionPtr = (castPtr $ ptr `plusPtr` fromIntegral offset)
, regionOffset = offset
, regionSize = fromIntegral size
, regionBuffer = buffer
}
readWhole :: (MonadIO m,Readable r,Storable a) => Region r a -> m [a]
readWhole r = liftIO $ peekArray (regionSize r) (regionPtr r)
writeWhole :: (Foldable f,MonadIO m,Storable a,Writable w)
=> Region w a
-> f a
-> m ()
writeWhole r values = liftIO . pokeArray (regionPtr r) . take (regionSize r) $ toList values
fill :: (MonadIO m,Storable a,Writable w) => Region w a -> a -> m ()
fill r a = liftIO . pokeArray (regionPtr r) $ replicate (regionSize r) a
(@?) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m (Maybe a)
r @? i
| i >= fromIntegral (regionSize r) = pure Nothing
| otherwise = liftIO $ Just <$> peekElemOff (regionPtr r) (fromIntegral i)
(@!) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m a
r @! i = liftIO $ peekElemOff (regionPtr r) (fromIntegral i)
writeAt :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m ()
writeAt r i a
| i >= fromIntegral (regionSize r) = pure ()
| otherwise = liftIO $ pokeElemOff (regionPtr r) (fromIntegral i) a
writeAt' :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m ()
writeAt' r i a = liftIO $ pokeElemOff (regionPtr r) (fromIntegral i) a