Traversable.hs

{- |
If you have a 'Trav.Traversable' instance of a record,
you can load and store all elements,
that are accessible by @Traversable@ methods.
We treat the record like an array,
that is we assume, that all elements have the same size and alignment.

Example:

> import Foreign.Storable.Traversable as Store
>
> data Stereo a = Stereo {left, right :: a}
>
> instance Functor Stereo where
>    fmap = Trav.fmapDefault
>
> instance Foldable Stereo where
>    foldMap = Trav.foldMapDefault
>
> instance Traversable Stereo where
>    sequenceA ~(Stereo l r) = liftA2 Stereo l r
>
> instance (Storable a) => Storable (Stereo a) where
>    sizeOf = Store.sizeOf
>    alignment = Store.alignment
>    peek = Store.peek (error "instance Traversable Stereo is lazy, so we do not provide a real value here")
>    poke = Store.poke

You would certainly not define the 'Trav.Traversable' and according instances
just for the implementation of the 'Storable' instance,
but there are usually similar applications
where the @Traversable@ instance is useful.
-}
module Foreign.Storable.Traversable (
   alignment, sizeOf,
   peek, poke,
   peekApplicative,
   ) where

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import qualified Control.Applicative as App

import Control.Monad.Trans.State
          (StateT, evalStateT, get, put, modify, )
import Control.Monad.Trans (liftIO, )

import Foreign.Storable.FixedArray (roundUp, )
import qualified Foreign.Storable as St

import Foreign.Ptr (Ptr, castPtr, )
import Foreign.Storable (Storable, )
import Foreign.Marshal.Array (advancePtr, )


{-# INLINE elementType #-}
elementType :: f a -> a
elementType _ =
   error "Storable.Traversable.alignment and sizeOf may not depend on element values"

{-# INLINE alignment #-}
alignment ::
   (Fold.Foldable f, Storable a) =>
   f a -> Int
alignment = St.alignment . elementType

{-# INLINE sizeOf #-}
sizeOf ::
   (Fold.Foldable f, Storable a) =>
   f a -> Int
sizeOf f =
   Fold.foldl' (\s _ -> s + 1) 0 f *
   roundUp (alignment f) (St.sizeOf (elementType f))


{- |
@peek skeleton ptr@ fills the @skeleton@ with data read from memory beginning at @ptr@.
The skeleton is needed formally for using 'Trav.Traversable'.
For instance when reading a list, it is not clear,
how many elements shall be read.
Using the skeleton you can give this information
and you also provide information that is not contained in the element type @a@.
For example you can call

> peek (replicate 10 ()) ptr

for reading 10 elements from memory starting at @ptr@.
-}
{-# INLINE peek #-}
peek ::
   (Trav.Traversable f, Storable a) =>
   f () -> Ptr (f a) -> IO (f a)
peek skeleton =
   evalStateT (Trav.mapM (const peekState) skeleton) .
   castPtr

{- |
Like 'peek' but uses 'pure' for construction of the result.
'pure' would be in class @Pointed@ if that would exist.
Thus we use the closest approximate 'Applicative'.
-}
{-# INLINE peekApplicative #-}
peekApplicative ::
   (App.Applicative f, Trav.Traversable f, Storable a) =>
   Ptr (f a) -> IO (f a)
peekApplicative =
   evalStateT (Trav.sequence (App.pure peekState)) . castPtr

{-# INLINE peekState #-}
peekState ::
   (Storable a) =>
   StateT (Ptr a) IO a
peekState =
   get >>= \p -> put (advancePtr p 1) >> liftIO (St.peek p)

{-# INLINE poke #-}
poke ::
   (Fold.Foldable f, Storable a) =>
   Ptr (f a) -> f a -> IO ()
poke ptr x =
   evalStateT (Fold.traverse_ pokeState x) $
   castPtr ptr

{-# INLINE pokeState #-}
pokeState ::
   (Storable a) =>
   a -> StateT (Ptr a) IO ()
pokeState x = do
   liftIO . flip St.poke x =<< get
   modify (flip advancePtr 1)