autopeek / autopoke

GenS.hs

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances  #-}

module GenS (AutoStorable) where

import Control.Applicative
import GHC.Generics
import Data.Word
import Foreign

class AutoStorable a

instance (Generic a, AutoStorable a, GStorable (Rep a)) => Storable a where
  peek      = fmap to . gpeek . castPtr
  poke p    = gpoke (castPtr p) . from
  sizeOf    = gsizeof . from
  alignment = galignment . from


class GStorable a where
  gpeek      :: Ptr (a p) -> IO (a p)
  gpoke      :: Ptr (a p) -> (a p) -> IO ()
  gsizeof    :: (a p) -> Int
  galignment :: (a p) -> Int

instance GStorable U1 where
  gpeek _      = return U1
  gpoke _ U1   = return ()
  gsizeof    _ = 0
  galignment _ = 0

instance GStorable f => GStorable (M1 i c f) where
  gpeek p    = M1 <$> gpeek (castPtr p)
  gpoke p    = gpoke (castPtr p) . unM1
  gsizeof    = gsizeof           . unM1
  galignment = galignment        . unM1

instance (Storable a) => GStorable (K1 i a) where
  gpeek p    = K1 <$> peek (castPtr p)
  gpoke p    = poke (castPtr p) . unK1
  gsizeof    = sizeOf           . unK1
  galignment = alignment        . unK1

instance (GStorable f, GStorable g) => GStorable ((:*:) f g) where
  gpeek p = do
    a <- gpeek (castPtr p)
    (a :*:) <$> gpeek (p `plusPtr` gsizeof a)
  gpoke p (a :*: b) =
    gpoke (castPtr p) a >> gpoke (p `plusPtr` gsizeof a) b
  gsizeof    _ = gsizeof (undefined :: f p) +
                 gsizeof (undefined :: g p)
  galignment _ = max (galignment (undefined :: f p))
                     (galignment (undefined :: g p))

instance (GStorable f, GStorable g) => GStorable ((:+:) f g) where
  gpeek p = do
    n <- peek (castPtr p)
    case n :: Word8 of
         0 -> L1 <$> gpeek (incPtr p)
         1 -> R1 <$> gpeek (incPtr p)
  gpoke p (L1 f) = poke (castPtr p) (0 :: Word8) >> gpoke (incPtr p) f
  gpoke p (R1 g) = poke (castPtr p) (1 :: Word8) >> gpoke (incPtr p) g
  gsizeof    _   = max (gsizeof (undefined :: f p))
                       (gsizeof (undefined :: g p)) + 1
  galignment _   = max (galignment (undefined :: f p))
                       (galignment (undefined :: g p))

incPtr :: Ptr a -> Ptr b
incPtr p = castPtr (p `plusPtr` 1)

time.hs

{-# LANGUAGE DeriveGeneric, ForeignFunctionInterface #-}

import Control.Applicative
import GHC.Generics
import Foreign
import Foreign.C

import GenS


data Timeval = Timeval { tv_time_t, tv_usec_t :: CLong }
  deriving (Show, Generic)

instance AutoStorable Timeval

foreign import ccall "gettimeofday"
  c'gettimeofday :: Ptr Timeval -> Ptr () -> IO CInt

gettimeofday :: IO Timeval
gettimeofday = outparam (`c'gettimeofday` nullPtr)


data Timespec = Timespec { ts_time_t :: CTime, ts_tv_nsec :: CLong }
  deriving (Show, Generic)

instance AutoStorable Timespec

data Clock = ClockRealtime
           | ClockMonotonic
           | ClockProcessCputimeId
           | ClockThreadCputimeId
           | ClockMonotonicRaw
           | ClockRealtimeCoarse
           | ClockMonotonicCoarse
           | ClockBoottime
           | ClockRealtimeAlarm
           | ClockBoottimeAlarm
  deriving (Show, Eq, Enum, Bounded)


foreign import ccall "clock_gettime"
  c'clock_gettime :: Word32 -> Ptr Timespec -> IO CInt
foreign import ccall "clock_settime"
  c'clock_settime :: Word32 -> Ptr Timespec -> IO CInt
foreign import ccall "clock_getres"
  c'clock_getres :: Word32 -> Ptr Timespec -> IO CInt

clockGetTime, clockGetRes :: Clock -> IO Timespec

clockGetTime = outparam . c'clock_gettime . fromEnumG
clockGetRes  = outparam . c'clock_getres  . fromEnumG

clockSetTime :: Clock -> Timespec -> IO Bool
clockSetTime clk ts = (== 0) <$> with ts (c'clock_settime $ fromEnumG clk)

-- ###

outparam :: Storable a => (Ptr a -> IO b) -> IO a
outparam f = alloca $ \p -> f p >> peek p

fromEnumG :: (Enum a, Num b) => a -> b
fromEnumG = fromIntegral . fromEnum