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 {
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 Semigroup Alignment where
Alignment x <> Alignment y = Alignment (lcm x y)
instance Monoid Alignment where
mempty = Alignment 1
mappend = (<>)
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 $ do
modify (roundUp align)
offset <- get
modify (+size)
return $
Compose $ reader $ \ptr ->
Box
(St.peekByteOff ptr offset)
(ReaderT $ St.pokeByteOff ptr offset . f)
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)