{- |
Here we show an example of how to
define a Storable instance with this module.

> import Foreign.Storable.Record as Store
> import Foreign.Storable (Storable (..), )
>
> import Control.Applicative (liftA2, )
>
> data Stereo a = Stereo {left, right :: a}
>
> store :: Storable a => Store.Dictionary (Stereo a)
> store =
>    Store.run $
>    liftA2 Stereo
>       (Store.element left)
>       (Store.element right)
>
> instance (Storable a) => Storable (Stereo a) where
>    sizeOf = Store.sizeOf store
>    alignment = Store.alignment store
>    peek = Store.peek store
>    poke = Store.poke store


The @Stereo@ constructor is exclusively used
for constructing the @peek@ function,
whereas the accessors in the @element@ calls
are used for assembling the @poke@ function.
It is required that the order of arguments of @Stereo@
matches the record accessors in the @element@ calls.
If you want that the stored data correctly and fully represents
your Haskell data, it must hold:

>   Stereo (left x) (right x) = x   .

Unfortunately this cannot be checked automatically.
However, mismatching types that are caused by swapped arguments
are detected by the type system.
Our system performs for you:
Size and alignment computation, poking and peeking.
Thus several inconsistency bugs can be prevented using this package,
like size mismatching the space required by @poke@ actions.
There is no more restriction,
thus smart constructors and accessors
and nested records work, too.
For nested records however,
I recommend individual Storable instances for the sub-records.

You see it would simplify class instantiation
if we could tell the class dictionary at once
instead of defining each method separately.

In this implementation we tail pad records
according to the overall required alignment
in conformance to the Linux/X86 ABI.
-}
module Foreign.Storable.Record (
   Dictionary, Access,
   element, run,

   alignment, sizeOf,
   peek, poke,
   ) where

import Control.Monad.Trans.Writer
          (Writer, writer, runWriter, )
import Control.Monad.Trans.State
          (State, modify, get, runState, )
import Control.Applicative (Applicative(pure, (<*>)), )
import Data.Functor.Compose (Compose(Compose), )
import Data.Monoid (Monoid(mempty, mappend), )
import Data.Semigroup (Semigroup((<>)), )

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

import Foreign.Ptr (Ptr, )
import Foreign.Storable (Storable, )


data Dictionary r =
   Dictionary {
      forall r. Dictionary r -> Int
sizeOf_ :: Int,
      forall r. Dictionary r -> Alignment
alignment_ :: Alignment,
      forall r. Dictionary r -> Box r r
ptrBox :: Box r r
   }

newtype Access r a =
   Access
      (Compose (Writer Alignment)
        (Compose (State Int)
          (Box r))
        a)

instance Functor (Access r) where
   {-# INLINE fmap #-}
   fmap :: forall a b. (a -> b) -> Access r a -> Access r b
fmap a -> b
f (Access Compose (Writer Alignment) (Compose (State Int) (Box r)) a
m) = forall r a.
Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
Access (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Compose (Writer Alignment) (Compose (State Int) (Box r)) a
m)

instance Applicative (Access r) where
   {-# INLINE pure #-}
   {-# INLINE (<*>) #-}
   pure :: forall a. a -> Access r a
pure a
a = forall r a.
Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
Access (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
   Access Compose (Writer Alignment) (Compose (State Int) (Box r)) (a -> b)
f <*> :: forall a b. Access r (a -> b) -> Access r a -> Access r b
<*> Access Compose (Writer Alignment) (Compose (State Int) (Box r)) a
x = forall r a.
Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
Access (Compose (Writer Alignment) (Compose (State Int) (Box r)) (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Compose (Writer Alignment) (Compose (State Int) (Box r)) a
x)


{-
For a version with (Ptr r) factored out, see RecordReaderPtr.
That is slightly slower.
-}
data Box r a =
   Box {
      forall r a. Box r a -> Ptr r -> IO a
peek_ :: Ptr r -> IO a,
      forall r a. Box r a -> Ptr r -> r -> IO ()
poke_ :: Ptr r -> r -> IO ()
   }

instance Functor (Box r) where
   {-# INLINE fmap #-}
   fmap :: forall a b. (a -> b) -> Box r a -> Box r b
fmap a -> b
f (Box Ptr r -> IO a
pe Ptr r -> r -> IO ()
po) =
      forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr r -> IO a
pe) Ptr r -> r -> IO ()
po

instance Applicative (Box r) where
   {-# INLINE pure #-}
   {-# INLINE (<*>) #-}
   pure :: forall a. a -> Box r a
pure a
a = forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
   Box r (a -> b)
f <*> :: forall a b. Box r (a -> b) -> Box r a -> Box r b
<*> Box r a
x =
      forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box
         (\Ptr r
ptr -> forall r a. Box r a -> Ptr r -> IO a
peek_ Box r (a -> b)
f Ptr r
ptr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall r a. Box r a -> Ptr r -> IO a
peek_ Box r a
x Ptr r
ptr)
         (\Ptr r
ptr r
r -> forall r a. Box r a -> Ptr r -> r -> IO ()
poke_ Box r (a -> b)
f Ptr r
ptr r
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r a. Box r a -> Ptr r -> r -> IO ()
poke_ Box r a
x Ptr r
ptr r
r)


newtype Alignment = Alignment {Alignment -> Int
deconsAlignment :: Int}

instance Semigroup Alignment where
   {-# INLINE (<>) #-}
   Alignment Int
x <> :: Alignment -> Alignment -> Alignment
<> Alignment Int
y = Int -> Alignment
Alignment (forall a. Integral a => a -> a -> a
lcm Int
x Int
y)

instance Monoid Alignment where
   {-# INLINE mempty #-}
   {-# INLINE mappend #-}
   mempty :: Alignment
mempty = Int -> Alignment
Alignment Int
1
   mappend :: Alignment -> Alignment -> Alignment
mappend = forall a. Semigroup a => a -> a -> a
(<>)


{-# INLINE element #-}
element :: Storable a => (r -> a) -> Access r a
element :: forall a r. Storable a => (r -> a) -> Access r a
element r -> a
f =
   let align :: Int
align = forall a. Storable a => a -> Int
St.alignment (r -> a
f (forall a. HasCallStack => [Char] -> a
error [Char]
"Storable.Record.element.alignment: content touched"))
       size :: Int
size  = forall a. Storable a => a -> Int
St.sizeOf (r -> a
f (forall a. HasCallStack => [Char] -> a
error [Char]
"Storable.Record.element.size: content touched"))
   in  forall r a.
Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
Access forall a b. (a -> b) -> a -> b
$
       forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (Int -> Alignment
Alignment Int
align) forall a b. (a -> b) -> a -> b
$
       forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Int -> Int -> Int
roundUp Int
align)
          Int
offset <- forall (m :: * -> *) s. Monad m => StateT s m s
get
          forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. Num a => a -> a -> a
+Int
size)
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box
             (\Ptr r
ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
St.peekByteOff Ptr r
ptr Int
offset)
             (\Ptr r
ptr -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
St.pokeByteOff Ptr r
ptr Int
offset forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
f)

{-# INLINE run #-}
run :: Access r r -> Dictionary r
run :: forall r. Access r r -> Dictionary r
run (Access (Compose Writer Alignment (Compose (State Int) (Box r) r)
m)) =
   let (Compose State Int (Box r r)
s, Alignment
align) = forall w a. Writer w a -> (a, w)
runWriter Writer Alignment (Compose (State Int) (Box r) r)
m
       (Box r r
box, Int
size) = forall s a. State s a -> s -> (a, s)
runState State Int (Box r r)
s Int
0
   in  forall r. Int -> Alignment -> Box r r -> Dictionary r
Dictionary (Int -> Int -> Int
roundUp (Alignment -> Int
deconsAlignment Alignment
align) Int
size) Alignment
align Box r r
box


{-# INLINE alignment #-}
alignment :: Dictionary r -> r -> Int
alignment :: forall r. Dictionary r -> r -> Int
alignment Dictionary r
dict r
_ =
   Alignment -> Int
deconsAlignment forall a b. (a -> b) -> a -> b
$ forall r. Dictionary r -> Alignment
alignment_ Dictionary r
dict

{-# INLINE sizeOf #-}
sizeOf :: Dictionary r -> r -> Int
sizeOf :: forall r. Dictionary r -> r -> Int
sizeOf Dictionary r
dict r
_ =
   forall r. Dictionary r -> Int
sizeOf_ Dictionary r
dict

{-# INLINE peek #-}
peek :: Dictionary r -> Ptr r -> IO r
peek :: forall r. Dictionary r -> Ptr r -> IO r
peek Dictionary r
dict Ptr r
ptr =
   forall r a. Box r a -> Ptr r -> IO a
peek_ (forall r. Dictionary r -> Box r r
ptrBox Dictionary r
dict) Ptr r
ptr

{-# INLINE poke #-}
poke :: Dictionary r -> Ptr r -> r -> IO ()
poke :: forall r. Dictionary r -> Ptr r -> r -> IO ()
poke Dictionary r
dict Ptr r
ptr =
   forall r a. Box r a -> Ptr r -> r -> IO ()
poke_ (forall r. Dictionary r -> Box r r
ptrBox Dictionary r
dict) Ptr r
ptr