ADTStorable.hs

{-# LANGUAGE ScopedTypeVariables #-}

module ADTStorable where 

import Foreign.Storable
import Foreign.Ptr

import Data.Word (Word8)

instance forall a . Storable a => Storable (Maybe a) where
    sizeOf x = alignment x + sizeOf (undefined :: a)
    alignment _ = alignment (undefined :: a)
    peek ptr = do
        tag <- peek (castPtr ptr :: Ptr Word8)
        case tag of
            0 -> return Nothing
            1 -> do
                let ptr' = ptr `plusPtr` alignment (undefined :: Maybe a)
                value <- peek (castPtr ptr' :: Ptr a)
                return (Just value)
    poke ptr Nothing = do
        poke (castPtr ptr :: Ptr Word8) 0
    poke ptr (Just v) = do
        poke (castPtr ptr :: Ptr Word8) 1
        let ptr' = ptr `plusPtr` alignment (undefined :: a)
        poke (castPtr ptr' :: Ptr a) v

instance forall a b . (Storable a, Storable b) => Storable (Either a b) where
    sizeOf x = alignment x + max (sizeOf (undefined :: a)) (sizeOf (undefined :: b))
    alignment _ = lcm (alignment (undefined :: a)) (alignment (undefined :: b))
    peek ptr = do
        tag <- peek (castPtr ptr :: Ptr Word8)
        case tag of
            0 -> do
                let ptr' = ptr `plusPtr` alignment (undefined :: Either a b)
                value <- peek (castPtr ptr' :: Ptr a)
                return (Left value)
            1 -> do
                let ptr' = ptr `plusPtr` alignment (undefined :: Either a b)
                value <- peek (castPtr ptr' :: Ptr b)
                return (Right value)
    poke ptr (Left x) = do
        poke (castPtr ptr :: Ptr Word8) 0
        let ptr' = ptr `plusPtr` alignment (undefined :: Either a b)
        poke (castPtr ptr' :: Ptr a) x
    poke ptr (Right x) = do
        poke (castPtr ptr :: Ptr Word8) 1
        let ptr' = ptr `plusPtr` alignment (undefined :: Either a b)
        poke (castPtr ptr' :: Ptr b) x