{- |
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 {
      Dictionary r -> Int
sizeOf_ :: Int,
      Dictionary r -> Alignment
alignment_ :: Alignment,
      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 :: (a -> b) -> Access r a -> Access r b
fmap a -> b
f (Access Compose (Writer Alignment) (Compose (State Int) (Box r)) a
m) = Compose (Writer Alignment) (Compose (State Int) (Box r)) b
-> Access r b
forall r a.
Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
Access ((a -> b)
-> Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Compose (Writer Alignment) (Compose (State Int) (Box r)) b
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 :: a -> Access r a
pure a
a = Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
forall r a.
Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Access r a
Access (a -> Compose (Writer Alignment) (Compose (State Int) (Box r)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
   Access Compose (Writer Alignment) (Compose (State Int) (Box r)) (a -> b)
f <*> :: Access r (a -> b) -> Access r a -> Access r b
<*> Access Compose (Writer Alignment) (Compose (State Int) (Box r)) a
x = Compose (Writer Alignment) (Compose (State Int) (Box r)) b
-> Access r b
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 Compose (Writer Alignment) (Compose (State Int) (Box r)) (a -> b)
-> Compose (Writer Alignment) (Compose (State Int) (Box r)) a
-> Compose (Writer Alignment) (Compose (State Int) (Box r)) b
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 {
      Box r a -> Ptr r -> IO a
peek_ :: Ptr r -> IO a,
      Box r a -> Ptr r -> r -> IO ()
poke_ :: Ptr r -> r -> IO ()
   }

instance Functor (Box r) where
   {-# INLINE fmap #-}
   fmap :: (a -> b) -> Box r a -> Box r b
fmap a -> b
f (Box Ptr r -> IO a
pe Ptr r -> r -> IO ()
po) =
      (Ptr r -> IO b) -> (Ptr r -> r -> IO ()) -> Box r b
forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box ((a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (IO a -> IO b) -> (Ptr r -> IO a) -> Ptr r -> IO b
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 :: a -> Box r a
pure a
a = (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box (IO a -> Ptr r -> IO a
forall a b. a -> b -> a
const (IO a -> Ptr r -> IO a) -> IO a -> Ptr r -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) ((r -> IO ()) -> Ptr r -> r -> IO ()
forall a b. a -> b -> a
const ((r -> IO ()) -> Ptr r -> r -> IO ())
-> (r -> IO ()) -> Ptr r -> r -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> r -> IO ()
forall a b. a -> b -> a
const (IO () -> r -> IO ()) -> IO () -> r -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
   Box r (a -> b)
f <*> :: Box r (a -> b) -> Box r a -> Box r b
<*> Box r a
x =
      (Ptr r -> IO b) -> (Ptr r -> r -> IO ()) -> Box r b
forall r a. (Ptr r -> IO a) -> (Ptr r -> r -> IO ()) -> Box r a
Box
         (\Ptr r
ptr -> Box r (a -> b) -> Ptr r -> IO (a -> b)
forall r a. Box r a -> Ptr r -> IO a
peek_ Box r (a -> b)
f Ptr r
ptr IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box r a -> Ptr r -> IO a
forall r a. Box r a -> Ptr r -> IO a
peek_ Box r a
x Ptr r
ptr)
         (\Ptr r
ptr r
r -> Box r (a -> b) -> Ptr r -> r -> IO ()
forall r a. Box r a -> Ptr r -> r -> IO ()
poke_ Box r (a -> b)
f Ptr r
ptr r
r IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Box r a -> Ptr r -> r -> IO ()
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 (Int -> Int -> Int
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 = Alignment -> Alignment -> Alignment
forall a. Semigroup a => a -> a -> a
(<>)


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

{-# INLINE run #-}
run :: Access r r -> Dictionary r
run :: 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) = Writer Alignment (Compose (State Int) (Box r) r)
-> (Compose (State Int) (Box r) r, Alignment)
forall w a. Writer w a -> (a, w)
runWriter Writer Alignment (Compose (State Int) (Box r) r)
m
       (Box r r
box, Int
size) = State Int (Box r r) -> Int -> (Box r r, Int)
forall s a. State s a -> s -> (a, s)
runState State Int (Box r r)
s Int
0
   in  Int -> Alignment -> Box r r -> Dictionary r
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 :: Dictionary r -> r -> Int
alignment Dictionary r
dict r
_ =
   Alignment -> Int
deconsAlignment (Alignment -> Int) -> Alignment -> Int
forall a b. (a -> b) -> a -> b
$ Dictionary r -> Alignment
forall r. Dictionary r -> Alignment
alignment_ Dictionary r
dict

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

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

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