{-# LANGUAGE DefaultSignatures #-}
-- | This module provides the mechanical deriving
-- mechanism for `CStorable'.
module Foreign.CStorable.TypeClass where
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics
-- | A wrapper class for the raw autoderivation functions,
-- representing twhat is necessary for the defaulted
-- `CStorable' methods.
class GCStorable a where
gcAlignment :: a x -> Int
gcPeek :: Int -> Ptr (a x)-> IO (a x)
gcPoke :: Int -> Ptr (a x) -> a x -> IO ()
gcSizeOf :: Int -> a x -> Int
-- padding before the field to align from the given offset
gcPadding :: Int -> a x -> Int
gcPadding off a = (gcAlignment a - off) `mod` gcAlignment a
instance GCStorable U1 where
gcAlignment _ = 0
gcPeek _ _ = return U1
gcPoke _ _ _ = return ()
gcSizeOf _ _ = 0
gcPadding _ _ = 0
-- | Test
instance (GCStorable a, GCStorable b) => GCStorable (a :*: b) where
gcAlignment _ = lcm (gcAlignment (undefined :: a x))
(gcAlignment (undefined :: b y))
gcPeek off p = do
a <- gcPeek off $ castPtr p
b <- gcPeek (off + gcSizeOf off a) $ castPtr p
return $ a :*: b
gcPoke off p (a :*: b) = do
gcPoke off (castPtr p) a
gcPoke (off + gcSizeOf off a) (castPtr p) b
gcSizeOf off _ = let
a = undefined :: a x
b = undefined :: b y
off2 = off + gcSizeOf off a
in gcSizeOf off a + gcSizeOf off2 b
instance (GCStorable a) => GCStorable (M1 i c a) where
gcAlignment (M1 x) = gcAlignment x
gcPeek off p = fmap M1 $ gcPeek off (castPtr p)
gcPoke off p (M1 x) = gcPoke off (castPtr p) x
gcSizeOf off (M1 x) = gcSizeOf off x
gcPadding off (M1 x) = gcPadding off x
instance (CStorable a) => GCStorable (K1 i a) where
gcAlignment (K1 x) = cAlignment x
gcPeek off p = fmap K1 $ cPeek (castPtr p `plusPtr` (off + gcPadding off (undefined :: K1 i a x)))
gcPoke off p (K1 x) = cPoke (castPtr p `plusPtr` (off + gcPadding off (undefined :: K1 i a x))) x
gcSizeOf off (K1 x) = gcPadding off (undefined :: K1 i a x) + cSizeOf x
-- | This typeclass is basically just a duplicate of `Storable'. It exists
-- because I can't easily modify `Storable', as it is part of base.
class CStorable a where
cPeek :: Ptr a -> IO a
default cPeek :: (Generic a, GCStorable (Rep a)) => Ptr a -> IO a
cPeek p = fmap to $ gcPeek 0 (castPtr p)
cPoke :: Ptr a -> a -> IO ()
default cPoke :: (Generic a, GCStorable (Rep a)) => Ptr a -> a -> IO ()
cPoke p x = gcPoke 0 (castPtr p) $ from x
cAlignment :: a -> Int
default cAlignment :: (Generic a, GCStorable (Rep a)) => a -> Int
cAlignment = gcAlignment . from
cSizeOf :: a -> Int
default cSizeOf :: (Generic a, GCStorable (Rep a)) => a -> Int
cSizeOf = gcSizeOf 0 . from