peek / poke

Peek.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}

module Peek (
  module Data.Monoid
, Store, runStore, store, stores
, Restorable, restore
, AutoSize, autoSizeOf
) where

import Control.Monad
import Control.Applicative
import Data.Monoid

import Foreign


data Store = Store (Ptr () -> IO (Ptr ()))

runStore :: Store -> Ptr a -> IO ()
runStore (Store f) p = f (castPtr p) >> return ()

store :: Storable a => a -> Store
store a = Store $ \p ->
  (p `plusPtr` sizeOf a) <$ poke (castPtr p) a

stores :: [Store] -> Ptr a -> IO ()
stores = runStore . mconcat

instance Monoid Store where
  mempty = Store return
  Store f `mappend` Store g = Store $ f >=> g


class Restorable a b where
  _restore :: a -> Ptr () -> IO b

instance Restorable a a where
  _restore = const . return

instance (Restorable b c, Storable a) => Restorable (a -> b) c where
  _restore f p = do
    a <- peek (castPtr p)
    _restore (f a) (p `plusPtr` sizeOf a)

restore :: Restorable f a => f -> Ptr a -> IO a
restore f = _restore f . castPtr


class AutoSize a where autoSizeOf :: a -> Int

instance AutoSize a where autoSizeOf _ = 0

instance (AutoSize b, Storable a) => AutoSize (a -> b) where
  autoSizeOf f = (\a -> autoSizeOf (f a) + sizeOf a) undefined

point1.hs

import Control.Applicative

import Foreign
import Foreign.C


data Point = Point Int Int
  deriving (Show)


sizeOf_int = sizeOf (undefined :: Int)

instance Storable Point where
  sizeOf _    = 2 * sizeOf_int
  alignment _ = 2 * sizeOf_int
  peek p = Point <$> peek (castPtr p)
                 <*> peek (p `plusPtr` sizeOf_int )
  poke p (Point x y) = do
    poke (castPtr p) x
    poke (castPtr p `plusPtr` sizeOf_int) y

point2.hs

import Foreign
import Foreign.C

import Peek


data Point = Point Int Int
  deriving (Show)

instance Storable Point where
  sizeOf _  = autoSizeOf Point
  alignment = sizeOf
  peek      = restore Point
  poke p (Point x y) = stores [store x, store y] p