storable-record-0.0.4/0000755000000000000000000000000013242064004012763 5ustar0000000000000000storable-record-0.0.4/storable-record.cabal0000644000000000000000000000727413242064004017050 0ustar0000000000000000Name: storable-record Version: 0.0.4 Category: Data, Foreign Synopsis: Elegant definition of Storable instances for records Description: With this package you can build a Storable instance of a record type from Storable instances of its elements in an elegant way. It does not do any magic, just a bit arithmetic to compute the right offsets, that would be otherwise done manually or by a preprocessor like C2HS. I cannot promise that the generated memory layout is compatible with that of a corresponding C struct. However, the module generates the smallest layout that is possible with respect to the alignment of the record elements. If you encounter, that a record does not have a compatible layout, we should fix that. But also without C compatibility this package is useful e.g. in connection with StorableVector. . We provide Storable instance support for several cases: . * If you wrap a type in a @newtype@, then you can lift its 'Storable' instance to that @newtype@ with the module "Foreign.Storable.Newtype". This way you do not need the @GeneralizedNewtypeDeriving@ feature of GHC. . * If you have a type that is an instance of 'Traversable', you can use that feature for implementation of 'Storable' methods. The module "Foreign.Storable.Traversable" allows manipulation of the portion of your type, that is accessible by 'Traversable' methods. For instance with the type @data T a = Cons Int [a]@ and an according 'Traversable' implementation, you can load and store the elements of the contained list. This may be part of a 'Storable' implementation of the whole type. . * If you have a record containing elements of various types, then you need module "Foreign.Storable.Record". . Note however that the Storable instances defined with this package are quite slow in (up to) GHC-6.12.1. I'm afraid this is due to incomplete inlining, but we have still to investigate the problem. . For examples see packages @storable-tuple@ and @sample-frame@. License: BSD3 License-file: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann Homepage: http://code.haskell.org/~thielema/storable-record/ Stability: Experimental Build-Type: Simple Tested-With: GHC==6.8.2, GHC==6.10.4, GHC==6.12.1, GHC==8.0.1 Cabal-Version: >=1.6 Source-Repository head Type: darcs Location: http://code.haskell.org/~thielema/storable-record/ Source-Repository this Type: darcs Location: http://code.haskell.org/~thielema/storable-record/ Tag: 0.0.4 Flag splitBase description: Choose the new smaller, split-up base package. Flag buildTests description: Build speed test default: False Library Build-Depends: transformers >=0.2 && <0.6, semigroups >=0.1 && <1.0, utility-ht >=0.0.1 && <0.1 If flag(splitBase) Build-Depends: base >= 3 && < 6 Else Build-Depends: special-functors >= 1.0 && <1.1, base >= 1.0 && < 2 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: Foreign.Storable.Record Foreign.Storable.Newtype Foreign.Storable.Traversable Foreign.Storable.FixedArray Other-Modules: Foreign.Storable.RecordMinimalSize Foreign.Storable.RecordReaderPtr Foreign.Storable.TraversableUnequalSizes Executable storable-record-speed If flag(buildTests) Build-Depends: storablevector >=0.2.7 && <0.3, timeit >=1.0 && <1.1 Else Buildable: False GHC-Options: -Wall Hs-Source-Dirs: src Main-Is: SpeedTest.hs storable-record-0.0.4/Setup.lhs0000644000000000000000000000011513242064004014570 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain storable-record-0.0.4/LICENSE0000644000000000000000000000270313242064004013772 0ustar0000000000000000Copyright (c) Henning Thielemann 2009 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. storable-record-0.0.4/src/0000755000000000000000000000000013242064004013552 5ustar0000000000000000storable-record-0.0.4/src/SpeedTest.hs0000644000000000000000000000427113242064004016012 0ustar0000000000000000-- see also speed test in sample-frame package module Main where import qualified Data.StorableVector as SV import qualified System.TimeIt as T import Foreign.Storable.Newtype as StoreNew import Foreign.Storable.Record as Store import Foreign.Storable (Storable (..), ) import Control.Applicative (liftA2, ) import Data.Word (Word8, ) data MonoN a = MonoN {singleN :: a} deriving Show instance (Storable a) => Storable (MonoN a) where {- INLINE sizeOf -} sizeOf = StoreNew.sizeOf singleN {- INLINE alignment -} alignment = StoreNew.alignment singleN {- INLINE peek -} peek = StoreNew.peek MonoN {- INLINE poke -} poke = StoreNew.poke singleN newtype Mono a = Mono {single :: a} deriving Show {-# INLINE storeMono #-} storeMono :: Storable a => Store.Dictionary (Mono a) storeMono = Store.run $ fmap Mono $ Store.element single instance (Storable a) => Storable (Mono a) where {-# INLINE sizeOf #-} sizeOf = Store.sizeOf storeMono {-# INLINE alignment #-} alignment = Store.alignment storeMono {-# INLINE peek #-} peek = Store.peek storeMono {-# INLINE poke #-} poke = Store.poke storeMono data Stereo a = Stereo {left, right :: a} deriving Show -- inline makes performance even worse {- INLINE storeStereo -} storeStereo :: Storable a => Store.Dictionary (Stereo a) storeStereo = Store.run $ liftA2 Stereo (Store.element left) (Store.element right) instance (Storable a) => Storable (Stereo a) where {- INLINE sizeOf -} sizeOf = Store.sizeOf storeStereo {- INLINE alignment -} alignment = Store.alignment storeStereo {- INLINE peek -} peek = Store.peek storeStereo {- INLINE poke -} poke = Store.poke storeStereo size :: Int size = 10000000 main :: IO () main = mapM_ T.timeIt $ (print $ SV.last $ SV.iterateN size (1+) (0::Float)) : (print $ SV.last $ SV.iterateN size (1+) (0::Word8)) : (print $ SV.last $ SV.iterateN size (\x -> MonoN (singleN x + 1)) (MonoN (0::Float))) : (print $ SV.last $ SV.iterateN size (\x -> Mono (single x + 1)) (Mono (0::Float))) : (print $ SV.last $ SV.iterateN size (\x -> Stereo (left x + 1) (right x + 3)) (Stereo 1 2 :: Stereo Float)) : [] storable-record-0.0.4/src/Foreign/0000755000000000000000000000000013242064004015143 5ustar0000000000000000storable-record-0.0.4/src/Foreign/Storable/0000755000000000000000000000000013242064004016716 5ustar0000000000000000storable-record-0.0.4/src/Foreign/Storable/FixedArray.hs0000644000000000000000000000172713242064004021317 0ustar0000000000000000module Foreign.Storable.FixedArray where import Control.Monad.Trans.State (StateT, evalStateT, get, put, ) import Control.Monad.Trans.Class (lift, ) import Foreign.Ptr (Ptr, castPtr, ) import Foreign.Storable (Storable(..)) import Foreign.Marshal.Array (advancePtr, ) {-# INLINE roundUp #-} roundUp :: Int -> Int -> Int roundUp m x = x + mod (-x) m {-# INLINE sizeOfArray #-} sizeOfArray :: Storable a => Int -> a -> Int sizeOfArray n x = n * roundUp (alignment x) (sizeOf x) {-# INLINE pokeNext #-} pokeNext :: (Storable a) => a -> StateT (Ptr a) IO () pokeNext x = do ptr <- get lift $ poke ptr x put (ptr `advancePtr` 1) -- put (ptr `plusPtr` size x + div (- size x) (alignment x)) {-# INLINE peekNext #-} peekNext :: (Storable a) => StateT (Ptr a) IO a peekNext = do ptr <- get a <- lift $ peek ptr put (ptr `advancePtr` 1) return a run :: Ptr (t a) -> StateT (Ptr a) IO c -> IO c run ptr act = evalStateT act (castPtr ptr) storable-record-0.0.4/src/Foreign/Storable/RecordMinimalSize.hs0000644000000000000000000001175313242064004022641 0ustar0000000000000000{- | 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 choose the minimum size for a record, that is we omit tail padding, which saves space but is incompatible with Linux/X86 ABI. -} 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 {-# INLINE fmap #-} fmap f (Access m) = Access (fmap f m) instance Applicative (Access r) where {-# INLINE pure #-} {-# INLINE (<*>) #-} 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 {-# INLINE fmap #-} fmap f (Box pe po) = Box (fmap f pe) po instance Applicative (Box r) where {-# INLINE pure #-} {-# INLINE (<*>) #-} 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 {-# INLINE (<>) #-} Alignment x <> Alignment y = Alignment (lcm x y) instance Monoid Alignment where {-# INLINE mempty #-} {-# INLINE mappend #-} mempty = Alignment 1 mappend = (<>) {-# INLINE element #-} 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) {-# INLINE run #-} 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 {-# INLINE alignment #-} alignment :: Dictionary r -> r -> Int alignment dict _ = let (Alignment align) = alignment_ dict in align {-# INLINE sizeOf #-} sizeOf :: Dictionary r -> r -> Int sizeOf dict _ = sizeOf_ dict {-# INLINE peek #-} peek :: Dictionary r -> Ptr r -> IO r peek dict ptr = peek_ $ runReader (ptrBox dict) ptr {-# INLINE poke #-} poke :: Dictionary r -> Ptr r -> r -> IO () poke dict ptr = runReaderT (poke_ $ runReader (ptrBox dict) ptr) storable-record-0.0.4/src/Foreign/Storable/TraversableUnequalSizes.hs0000644000000000000000000000454513242064004024105 0ustar0000000000000000{- | If you have a Traversable instance of a record, you can load and store all elements, that are accessible by Traversable methods. In this attempt we support elements of unequal size. However this can be awfully slow, since the program might perform size computations at run-time. -} module Foreign.Storable.TraversableUnequalSizes ( alignment, sizeOf, peek, poke, ) where import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import Control.Monad.Trans.State (StateT, evalStateT, gets, modify, ) import Control.Monad.IO.Class (liftIO, ) import Foreign.Storable.FixedArray (roundUp, ) import qualified Foreign.Storable as St import Foreign.Ptr (Ptr, ) import Foreign.Storable (Storable, ) {-# INLINE alignment #-} alignment :: (Fold.Foldable f, Storable a) => f a -> Int alignment = Fold.foldl' (\n x -> lcm n (St.alignment x)) 1 {-# INLINE sizeOf #-} sizeOf :: (Fold.Foldable f, Storable a) => f a -> Int sizeOf f = roundUp (alignment f) $ Fold.foldl' (\s x -> roundUp (St.alignment x) s + St.sizeOf x) 0 f {- This function requires that alignment does not depend on an element value, because we cannot not know the value before loading it. Thus @alignment (undefined::a)@ must be defined. -} {-# INLINE peek #-} peek :: (Trav.Traversable f, Storable a) => f () -> Ptr (f a) -> IO (f a) peek skeleton ptr = evalStateT (Trav.mapM (const (peekState ptr)) skeleton) 0 {-# INLINE peekState #-} peekState :: (Storable a) => Ptr (f a) -> StateT Int IO a peekState p = do let pseudoPeek :: Ptr (f a) -> a pseudoPeek _ = error "Traversable.peek: alignment must not depend on the element value" k <- getOffset (pseudoPeek p) a <- liftIO (St.peekByteOff p k) advanceOffset a return a {-# INLINE poke #-} poke :: (Fold.Foldable f, Storable a) => Ptr (f a) -> f a -> IO () poke ptr x = evalStateT (Fold.traverse_ (pokeState ptr) x) 0 {-# INLINE pokeState #-} pokeState :: (Storable a) => Ptr (f a) -> a -> StateT Int IO () pokeState p a = do k <- getOffset a liftIO (St.pokeByteOff p k a) advanceOffset a {-# INLINE getOffset #-} getOffset :: (Storable a) => a -> StateT Int IO Int getOffset a = gets (roundUp (St.alignment a)) {-# INLINE advanceOffset #-} advanceOffset :: (Storable a) => a -> StateT Int IO () advanceOffset a = modify ( + St.sizeOf a) storable-record-0.0.4/src/Foreign/Storable/Traversable.hs0000644000000000000000000000712613242064004021532 0ustar0000000000000000{- | If you have a 'Trav.Traversable' instance of a record, you can load and store all elements, that are accessible by @Traversable@ methods. We treat the record like an array, that is we assume, that all elements have the same size and alignment. Example: > import Foreign.Storable.Traversable as Store > > data Stereo a = Stereo {left, right :: a} > > instance Functor Stereo where > fmap = Trav.fmapDefault > > instance Foldable Stereo where > foldMap = Trav.foldMapDefault > > instance Traversable Stereo where > sequenceA ~(Stereo l r) = liftA2 Stereo l r > > instance (Storable a) => Storable (Stereo a) where > sizeOf = Store.sizeOf > alignment = Store.alignment > peek = Store.peek (error "instance Traversable Stereo is lazy, so we do not provide a real value here") > poke = Store.poke You would certainly not define the 'Trav.Traversable' and according instances just for the implementation of the 'Storable' instance, but there are usually similar applications where the @Traversable@ instance is useful. -} module Foreign.Storable.Traversable ( alignment, sizeOf, peek, poke, peekApplicative, ) where import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Control.Applicative as App -- ToDo: Maybe we should use State.Strict instead? import Control.Monad.Trans.State (StateT, evalStateT, get, put, modify, ) import Control.Monad.IO.Class (liftIO, ) import Foreign.Storable.FixedArray (roundUp, ) import qualified Foreign.Storable as St import Foreign.Ptr (Ptr, castPtr, ) import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, ) {-# INLINE elementType #-} elementType :: f a -> a elementType _ = error "Storable.Traversable.alignment and sizeOf may not depend on element values" {-# INLINE alignment #-} alignment :: (Fold.Foldable f, Storable a) => f a -> Int alignment = St.alignment . elementType {-# INLINE sizeOf #-} sizeOf :: (Fold.Foldable f, Storable a) => f a -> Int sizeOf f = Fold.foldl' (\s _ -> s + 1) 0 f * roundUp (alignment f) (St.sizeOf (elementType f)) {- | @peek skeleton ptr@ fills the @skeleton@ with data read from memory beginning at @ptr@. The skeleton is needed formally for using 'Trav.Traversable'. For instance when reading a list, it is not clear, how many elements shall be read. Using the skeleton you can give this information and you also provide information that is not contained in the element type @a@. For example you can call > peek (replicate 10 ()) ptr for reading 10 elements from memory starting at @ptr@. -} {-# INLINE peek #-} peek :: (Trav.Traversable f, Storable a) => f () -> Ptr (f a) -> IO (f a) peek skeleton = evalStateT (Trav.mapM (const peekState) skeleton) . castPtr {- | Like 'peek' but uses 'pure' for construction of the result. 'pure' would be in class @Pointed@ if that would exist. Thus we use the closest approximate 'Applicative'. -} {-# INLINE peekApplicative #-} peekApplicative :: (App.Applicative f, Trav.Traversable f, Storable a) => Ptr (f a) -> IO (f a) peekApplicative = evalStateT (Trav.sequence (App.pure peekState)) . castPtr {-# INLINE peekState #-} peekState :: (Storable a) => StateT (Ptr a) IO a peekState = get >>= \p -> put (advancePtr p 1) >> liftIO (St.peek p) {-# INLINE poke #-} poke :: (Fold.Foldable f, Storable a) => Ptr (f a) -> f a -> IO () poke ptr x = evalStateT (Fold.traverse_ pokeState x) $ castPtr ptr {-# INLINE pokeState #-} pokeState :: (Storable a) => a -> StateT (Ptr a) IO () pokeState x = do liftIO . flip St.poke x =<< get modify (flip advancePtr 1) storable-record-0.0.4/src/Foreign/Storable/RecordReaderPtr.hs0000644000000000000000000001176113242064004022307 0ustar0000000000000000{- | 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.RecordReaderPtr ( 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 {-# INLINE fmap #-} fmap f (Access m) = Access (fmap f m) instance Applicative (Access r) where {-# INLINE pure #-} {-# INLINE (<*>) #-} 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 {-# INLINE fmap #-} fmap f (Box pe po) = Box (fmap f pe) po instance Applicative (Box r) where {-# INLINE pure #-} {-# INLINE (<*>) #-} pure a = Box (pure a) (pure ()) f <*> x = Box (peek_ f <*> peek_ x) (poke_ f >> poke_ x) newtype Alignment = Alignment {deconsAlignment :: Int} instance Semigroup Alignment where {-# INLINE (<>) #-} Alignment x <> Alignment y = Alignment (lcm x y) instance Monoid Alignment where {-# INLINE mempty #-} {-# INLINE mappend #-} mempty = Alignment 1 mappend = (<>) {-# INLINE element #-} 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) {-# INLINE run #-} run :: Access r r -> Dictionary r run (Access (Compose m)) = let (Compose s, align) = runWriter m (Compose r, size) = runState s 0 in Dictionary (roundUp (deconsAlignment align) size) align r {-# INLINE alignment #-} alignment :: Dictionary r -> r -> Int alignment dict _ = deconsAlignment $ alignment_ dict {-# INLINE sizeOf #-} sizeOf :: Dictionary r -> r -> Int sizeOf dict _ = sizeOf_ dict {-# INLINE peek #-} peek :: Dictionary r -> Ptr r -> IO r peek dict ptr = peek_ $ runReader (ptrBox dict) ptr {-# INLINE poke #-} poke :: Dictionary r -> Ptr r -> r -> IO () poke dict ptr = runReaderT (poke_ $ runReader (ptrBox dict) ptr) storable-record-0.0.4/src/Foreign/Storable/Newtype.hs0000644000000000000000000000167113242064004020712 0ustar0000000000000000{- | Storable instances for simple wrapped types. Example: > import Foreign.Storable.Newtype as Store > > newtype MuLaw = MuLaw {deMuLaw :: Word8} > > instance Storable MuLaw where > sizeOf = Store.sizeOf deMuLaw > alignment = Store.alignment deMuLaw > peek = Store.peek MuLaw > poke = Store.poke deMuLaw -} module Foreign.Storable.Newtype where import Foreign.Ptr (Ptr, castPtr, ) import Foreign.Storable (Storable, ) import qualified Foreign.Storable as Store sizeOf :: Storable core => (wrapper -> core) -> wrapper -> Int sizeOf unwrap = Store.sizeOf . unwrap alignment :: Storable core => (wrapper -> core) -> wrapper -> Int alignment unwrap = Store.alignment . unwrap peek :: Storable core => (core -> wrapper) -> Ptr wrapper -> IO wrapper peek wrap = fmap wrap . Store.peek . castPtr poke :: Storable core => (wrapper -> core) -> Ptr wrapper -> wrapper -> IO () poke unwrap ptr = Store.poke (castPtr ptr) . unwrap storable-record-0.0.4/src/Foreign/Storable/Record.hs0000644000000000000000000001163013242064004020471 0ustar0000000000000000{- | 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 { sizeOf_ :: Int, alignment_ :: Alignment, 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 f (Access m) = Access (fmap f m) instance Applicative (Access r) where {-# INLINE pure #-} {-# INLINE (<*>) #-} pure a = Access (pure a) Access f <*> Access x = Access (f <*> x) {- For a version with (Ptr r) factored out, see RecordReaderPtr. That is slightly slower. -} data Box r a = Box { peek_ :: Ptr r -> IO a, poke_ :: Ptr r -> r -> IO () } instance Functor (Box r) where {-# INLINE fmap #-} fmap f (Box pe po) = Box (fmap f . pe) po instance Applicative (Box r) where {-# INLINE pure #-} {-# INLINE (<*>) #-} pure a = Box (const $ pure a) (const $ const $ pure ()) f <*> x = Box (\ptr -> peek_ f ptr <*> peek_ x ptr) (\ptr r -> poke_ f ptr r >> poke_ x ptr r) newtype Alignment = Alignment {deconsAlignment :: Int} instance Semigroup Alignment where {-# INLINE (<>) #-} Alignment x <> Alignment y = Alignment (lcm x y) instance Monoid Alignment where {-# INLINE mempty #-} {-# INLINE mappend #-} mempty = Alignment 1 mappend = (<>) {-# INLINE element #-} 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 $ Box (\ptr -> St.peekByteOff ptr offset) (\ptr -> St.pokeByteOff ptr offset . f) {-# INLINE run #-} run :: Access r r -> Dictionary r run (Access (Compose m)) = let (Compose s, align) = runWriter m (box, size) = runState s 0 in Dictionary (roundUp (deconsAlignment align) size) align box {-# INLINE alignment #-} alignment :: Dictionary r -> r -> Int alignment dict _ = deconsAlignment $ alignment_ dict {-# INLINE sizeOf #-} sizeOf :: Dictionary r -> r -> Int sizeOf dict _ = sizeOf_ dict {-# INLINE peek #-} peek :: Dictionary r -> Ptr r -> IO r peek dict ptr = peek_ (ptrBox dict) ptr {-# INLINE poke #-} poke :: Dictionary r -> Ptr r -> r -> IO () poke dict ptr = poke_ (ptrBox dict) ptr