System/Event/Clock.hsc

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3
   4 module System.Event.Clock (getCurrentTime) where
   5
   6 #include <sys/time.h>
   7
   8 import Foreign (Ptr, Storable(..), nullPtr, with)
   9 import Foreign.C.Error (throwErrnoIfMinus1_)
  10 import Foreign.C.Types (CInt, CLong)
  11 import GHC.Base
  12 import GHC.Err
  13 import GHC.Num
  14 import GHC.Real
  15
  16 -- TODO: Implement this for Windows.
  17
  18 -- | Return the current time, in seconds since Jan. 1, 1970.
  19 getCurrentTime :: IO Double
  20 getCurrentTime = do
  21     tv <- with (CTimeval 0 0) $ \tvptr -> do
  22         throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr)
  23         peek tvptr
  24     let !t = fromIntegral (sec tv) + fromIntegral (usec tv) / 1000000.0
  25     return t
  26
  27 ------------------------------------------------------------------------
  28 -- FFI binding
  29
  30 data CTimeval = CTimeval
  31     { sec  :: {-# UNPACK #-} !CLong
  32     , usec :: {-# UNPACK #-} !CLong
  33     }
  34
  35 instance Storable CTimeval where
  36     sizeOf _ = #size struct timeval
  37     alignment _ = alignment (undefined :: CLong)
  38
  39     peek ptr = do
  40         sec' <- #{peek struct timeval, tv_sec} ptr
  41         usec' <- #{peek struct timeval, tv_usec} ptr
  42         return $ CTimeval sec' usec'
  43
  44     poke ptr tv = do
  45         #{poke struct timeval, tv_sec} ptr (sec tv)
  46         #{poke struct timeval, tv_usec} ptr (usec tv)
  47
  48 foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday
  49     :: Ptr CTimeval -> Ptr () -> IO CInt