module Foreign.Storable.Record (
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, state, runState, )
import Control.Applicative (Applicative(pure, (<*>)), )
import Data.Functor.Compose (Compose(Compose), )
import Data.Monoid (Monoid(mempty, mappend), )
import Foreign.Storable.FixedArray (roundUp, )
import qualified Foreign.Storable as St
import Foreign.Ptr (Ptr, )
import Foreign.Storable (Storable, )
data Dictionary r =
Dictionary {
sizeOf_ :: Int,
alignment_ :: Alignment,
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
fmap f (Access m) = Access (fmap f m)
instance Applicative (Access r) where
pure a = Access (pure a)
Access f <*> Access x = Access (f <*> x)
data Box r a =
Box {
peek_ :: IO a,
poke_ :: ReaderT r IO ()
}
instance Functor (Box r) where
fmap f (Box pe po) =
Box (fmap f pe) po
instance Applicative (Box r) where
pure a = Box (pure a) (pure ())
f <*> x = Box (peek_ f <*> peek_ x) (poke_ f >> poke_ x)
newtype Alignment = Alignment Int
instance Monoid Alignment where
mempty = Alignment 1
mappend (Alignment x) (Alignment y) = Alignment (lcm x y)
element :: Storable a => (r -> a) -> Access r a
element f =
let align = St.alignment (f (error "Storable.Record.element.alignment: content touched"))
size = St.sizeOf (f (error "Storable.Record.element.size: content touched"))
in Access $
Compose $ writer $ flip (,) (Alignment align) $
Compose $
modify (roundUp align) >>
state (\offset ->
(Compose $ reader $ \ptr ->
Box
(St.peekByteOff ptr offset)
(ReaderT $ St.pokeByteOff ptr offset . f),
offset+size))
run :: Access r r -> Dictionary r
run (Access (Compose m)) =
let (Compose s, align) = runWriter m
(Compose r, size) = runState s 0
in Dictionary size align r
alignment :: Dictionary r -> r -> Int
alignment dict _ =
let (Alignment align) = alignment_ dict
in align
sizeOf :: Dictionary r -> r -> Int
sizeOf dict _ =
sizeOf_ dict
peek :: Dictionary r -> Ptr r -> IO r
peek dict ptr =
peek_ $ runReader (ptrBox dict) ptr
poke :: Dictionary r -> Ptr r -> r -> IO ()
poke dict ptr =
runReaderT (poke_ $ runReader (ptrBox dict) ptr)