module Foreign.Storable.TraversableUnequalSizes (
alignment, sizeOf,
peek, poke,
) where
import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import Control.Monad.Trans.State
(StateT, evalStateT, gets, modify, )
import Control.Monad.IO.Class (liftIO, )
import Foreign.Storable.FixedArray (roundUp, )
import qualified Foreign.Storable as St
import Foreign.Ptr (Ptr, )
import Foreign.Storable (Storable, )
{-# INLINE alignment #-}
alignment ::
(Fold.Foldable f, Storable a) =>
f a -> Int
alignment =
Fold.foldl' (\n x -> lcm n (St.alignment x)) 1
{-# INLINE sizeOf #-}
sizeOf ::
(Fold.Foldable f, Storable a) =>
f a -> Int
sizeOf f =
roundUp (alignment f) $
Fold.foldl' (\s x -> roundUp (St.alignment x) s + St.sizeOf x) 0 f
{-# INLINE peek #-}
peek ::
(Trav.Traversable f, Storable a) =>
f () -> Ptr (f a) -> IO (f a)
peek skeleton ptr =
evalStateT (Trav.mapM (const (peekState ptr)) skeleton) 0
{-# INLINE peekState #-}
peekState ::
(Storable a) =>
Ptr (f a) -> StateT Int IO a
peekState p = do
let pseudoPeek :: Ptr (f a) -> a
pseudoPeek _ = error "Traversable.peek: alignment must not depend on the element value"
k <- getOffset (pseudoPeek p)
a <- liftIO (St.peekByteOff p k)
advanceOffset a
return a
{-# INLINE poke #-}
poke ::
(Fold.Foldable f, Storable a) =>
Ptr (f a) -> f a -> IO ()
poke ptr x =
evalStateT (Fold.traverse_ (pokeState ptr) x) 0
{-# INLINE pokeState #-}
pokeState ::
(Storable a) =>
Ptr (f a) -> a -> StateT Int IO ()
pokeState p a = do
k <- getOffset a
liftIO (St.pokeByteOff p k a)
advanceOffset a
{-# INLINE getOffset #-}
getOffset ::
(Storable a) =>
a -> StateT Int IO Int
getOffset a =
gets (roundUp (St.alignment a))
{-# INLINE advanceOffset #-}
advanceOffset ::
(Storable a) =>
a -> StateT Int IO ()
advanceOffset a =
modify ( + St.sizeOf a)