module Foreign.Storable.RecordMinimalSize (
Dictionary, Access,
element, run,
alignment, sizeOf,
peek, poke,
) where
import Control.Monad.Trans.Reader
(ReaderT(ReaderT), runReaderT,
Reader, reader, runReader, )
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 -> Reader (Ptr r) (Box r r)
ptrBox :: Reader (Ptr r) (Box r r)
}
newtype Access r a =
Access
(Compose (Writer Alignment)
(Compose (State Int)
(Compose (Reader (Ptr r))
(Box r)))
a)
instance Functor (Access r) where
{-# INLINE fmap #-}
fmap :: (a -> b) -> Access r a -> Access r b
fmap f :: a -> b
f (Access m :: Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
m) = Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
b
-> Access r b
forall r a.
Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
Access ((a -> b)
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (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) (Compose (Reader (Ptr r)) (Box r)))
a
m)
instance Applicative (Access r) where
{-# INLINE pure #-}
{-# INLINE (<*>) #-}
pure :: a -> Access r a
pure a :: a
a = Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
forall r a.
Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
Access (a
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
Access f :: Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
(a -> b)
f <*> :: Access r (a -> b) -> Access r a -> Access r b
<*> Access x :: Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
x = Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
b
-> Access r b
forall r a.
Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
Access (Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
(a -> b)
f Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
(a -> b)
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
x)
data Box r a =
Box {
Box r a -> IO a
peek_ :: IO a,
Box r a -> ReaderT r IO ()
poke_ :: ReaderT r IO ()
}
instance Functor (Box r) where
{-# INLINE fmap #-}
fmap :: (a -> b) -> Box r a -> Box r b
fmap f :: a -> b
f (Box pe :: IO a
pe po :: ReaderT r IO ()
po) =
IO b -> ReaderT r IO () -> Box r b
forall r a. IO a -> ReaderT 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
pe) ReaderT r IO ()
po
instance Applicative (Box r) where
{-# INLINE pure #-}
{-# INLINE (<*>) #-}
pure :: a -> Box r a
pure a :: a
a = IO a -> ReaderT r IO () -> Box r a
forall r a. IO a -> ReaderT r IO () -> Box r a
Box (a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (() -> ReaderT r IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
f :: Box r (a -> b)
f <*> :: Box r (a -> b) -> Box r a -> Box r b
<*> x :: Box r a
x = IO b -> ReaderT r IO () -> Box r b
forall r a. IO a -> ReaderT r IO () -> Box r a
Box (Box r (a -> b) -> IO (a -> b)
forall r a. Box r a -> IO a
peek_ Box r (a -> b)
f IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box r a -> IO a
forall r a. Box r a -> IO a
peek_ Box r a
x) (Box r (a -> b) -> ReaderT r IO ()
forall r a. Box r a -> ReaderT r IO ()
poke_ Box r (a -> b)
f ReaderT r IO () -> ReaderT r IO () -> ReaderT r IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Box r a -> ReaderT r IO ()
forall r a. Box r a -> ReaderT r IO ()
poke_ Box r a
x)
newtype Alignment = Alignment Int
instance Semigroup Alignment where
{-# INLINE (<>) #-}
Alignment x :: Int
x <> :: Alignment -> Alignment -> Alignment
<> Alignment y :: 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 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 f :: 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 "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 "Storable.Record.element.size: content touched"))
in Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
forall r a.
Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
Access (Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a)
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
-> Access r a
forall a b. (a -> b) -> a -> b
$
WriterT
Alignment
Identity
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a)
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (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) (Compose (Reader (Ptr r)) (Box r)) a)
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a)
-> WriterT
Alignment
Identity
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a)
-> Compose
(Writer Alignment)
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)))
a
forall a b. (a -> b) -> a -> b
$ (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment)
-> WriterT
Alignment
Identity
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a)
forall (m :: * -> *) a w. Monad m => (a, w) -> WriterT w m a
writer ((Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment)
-> WriterT
Alignment
Identity
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a))
-> (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment)
-> WriterT
Alignment
Identity
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a)
forall a b. (a -> b) -> a -> b
$ (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a
-> Alignment
-> (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment))
-> Alignment
-> Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a
-> (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (Int -> Alignment
Alignment Int
align) (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a
-> (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment))
-> Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a
-> (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a,
Alignment)
forall a b. (a -> b) -> a -> b
$
StateT Int Identity (Compose (Reader (Ptr r)) (Box r) a)
-> Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (StateT Int Identity (Compose (Reader (Ptr r)) (Box r) a)
-> Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) a)
-> StateT Int Identity (Compose (Reader (Ptr r)) (Box r) a)
-> Compose (State Int) (Compose (Reader (Ptr r)) (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)
Compose (Reader (Ptr r)) (Box r) a
-> StateT Int Identity (Compose (Reader (Ptr r)) (Box r) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Compose (Reader (Ptr r)) (Box r) a
-> StateT Int Identity (Compose (Reader (Ptr r)) (Box r) a))
-> Compose (Reader (Ptr r)) (Box r) a
-> StateT Int Identity (Compose (Reader (Ptr r)) (Box r) a)
forall a b. (a -> b) -> a -> b
$
ReaderT (Ptr r) Identity (Box r a)
-> Compose (Reader (Ptr r)) (Box r) a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ReaderT (Ptr r) Identity (Box r a)
-> Compose (Reader (Ptr r)) (Box r) a)
-> ReaderT (Ptr r) Identity (Box r a)
-> Compose (Reader (Ptr r)) (Box r) a
forall a b. (a -> b) -> a -> b
$ (Ptr r -> Box r a) -> ReaderT (Ptr r) Identity (Box r a)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader ((Ptr r -> Box r a) -> ReaderT (Ptr r) Identity (Box r a))
-> (Ptr r -> Box r a) -> ReaderT (Ptr r) Identity (Box r a)
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr r
ptr ->
IO a -> ReaderT r IO () -> Box r a
forall r a. IO a -> ReaderT r IO () -> Box r a
Box
(Ptr r -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
St.peekByteOff Ptr r
ptr Int
offset)
((r -> IO ()) -> ReaderT r IO ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> IO ()) -> ReaderT r IO ())
-> (r -> IO ()) -> ReaderT r IO ()
forall a b. (a -> b) -> a -> b
$ 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 m :: Writer
Alignment
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) r)
m)) =
let (Compose s :: State Int (Compose (Reader (Ptr r)) (Box r) r)
s, align :: Alignment
align) = Writer
Alignment
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) r)
-> (Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) r,
Alignment)
forall w a. Writer w a -> (a, w)
runWriter Writer
Alignment
(Compose (State Int) (Compose (Reader (Ptr r)) (Box r)) r)
m
(Compose r :: Reader (Ptr r) (Box r r)
r, size :: Int
size) = State Int (Compose (Reader (Ptr r)) (Box r) r)
-> Int -> (Compose (Reader (Ptr r)) (Box r) r, Int)
forall s a. State s a -> s -> (a, s)
runState State Int (Compose (Reader (Ptr r)) (Box r) r)
s 0
in Int -> Alignment -> Reader (Ptr r) (Box r r) -> Dictionary r
forall r.
Int -> Alignment -> Reader (Ptr r) (Box r r) -> Dictionary r
Dictionary Int
size Alignment
align Reader (Ptr r) (Box r r)
r
{-# INLINE alignment #-}
alignment :: Dictionary r -> r -> Int
alignment :: Dictionary r -> r -> Int
alignment dict :: Dictionary r
dict _ =
let (Alignment align :: Int
align) = Dictionary r -> Alignment
forall r. Dictionary r -> Alignment
alignment_ Dictionary r
dict
in Int
align
{-# INLINE sizeOf #-}
sizeOf :: Dictionary r -> r -> Int
sizeOf :: Dictionary r -> r -> Int
sizeOf dict :: Dictionary r
dict _ =
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 dict :: Dictionary r
dict ptr :: Ptr r
ptr =
Box r r -> IO r
forall r a. Box r a -> IO a
peek_ (Box r r -> IO r) -> Box r r -> IO r
forall a b. (a -> b) -> a -> b
$ Reader (Ptr r) (Box r r) -> Ptr r -> Box r r
forall r a. Reader r a -> r -> a
runReader (Dictionary r -> Reader (Ptr r) (Box r r)
forall r. Dictionary r -> Reader (Ptr 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 dict :: Dictionary r
dict ptr :: Ptr r
ptr =
ReaderT r IO () -> r -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Box r r -> ReaderT r IO ()
forall r a. Box r a -> ReaderT r IO ()
poke_ (Box r r -> ReaderT r IO ()) -> Box r r -> ReaderT r IO ()
forall a b. (a -> b) -> a -> b
$ Reader (Ptr r) (Box r r) -> Ptr r -> Box r r
forall r a. Reader r a -> r -> a
runReader (Dictionary r -> Reader (Ptr r) (Box r r)
forall r. Dictionary r -> Reader (Ptr r) (Box r r)
ptrBox Dictionary r
dict) Ptr r
ptr)