OK, I have my own darcs repository for code, but I seem to have trouble pushing it to the empty repository I set up on a server: <http://www.abridgegame.org/pipermail/darcs-users/2005-February/005828.ht ml> In the mean time, attached is a first attempt at an implementation of System.Time.Clock. It should compile OK. Some notes: * I use FFI to call gettimeofday to get the current day. * DiffTime and UTCDiffTime are instances of Num, Integral etc., and as such it represent picoseconds. This isn't ideal with regards to physical dimension, but that's the way the numeric classes are. * Arithmetic on UTC times works by "squeezing" leap seconds, i.e. converting them to POSIX times: 1998-12-31 23:59:60.5 UTC + 0 UTC = 1999-01-01 00:00:00.0 UTC I'm not sure what the best solution is here. * More haddock comments will be forthcoming... -- Ashley Yakeley, Seattle WA {-# OPTIONS -ffi -fglasgow-exts #-} module System.Time.Clock ( -- Modified Julian days and dates (for UT1) ModJulianDay,ModJulianDate, -- absolute time intervals DiffTime,timeToSISeconds,siSecondsToTime, -- UTC arithmetic UTCTime(..),UTCDiffTime,utcTimeToUTCSeconds,utcSecondsToUTCTime, addUTCTime,diffUTCTime, -- getting the current UTC time getCurrentTime ) where import Foreign import Foreign.C -- | standard Julian count of Earth days type ModJulianDay = Integer -- | standard Julian dates for UT1, 1 = 1 day type ModJulianDate = Rational secondPicoseconds :: (Num a) => a secondPicoseconds = 1000000000000 newtype DiffTime = MkDiffTime Integer deriving (Eq,Ord,Num,Enum,Real,Integral) instance Show DiffTime where show (MkDiffTime t) = (show t) ++ "ps" timeToSISeconds :: (Fractional a) => DiffTime -> a timeToSISeconds t = fromRational ((toRational t) / (toRational secondPicoseconds)); siSecondsToTime :: (Real a) => a -> DiffTime siSecondsToTime t = fromInteger (round ((toRational t) * secondPicoseconds)) data UTCTime = UTCTime { utctDay :: ModJulianDay, utctDayTime :: DiffTime } newtype UTCDiffTime = MkUTCDiffTime Integer deriving (Eq,Ord,Num,Enum,Real,Integral) instance Show UTCDiffTime where show (MkUTCDiffTime t) = (show t) ++ "ps" utcTimeToUTCSeconds :: (Fractional a) => UTCDiffTime -> a utcTimeToUTCSeconds t = fromRational ((toRational t) / (toRational secondPicoseconds)) utcSecondsToUTCTime :: (Real a) => a -> UTCDiffTime utcSecondsToUTCTime t = fromInteger (round ((toRational t) * secondPicoseconds)) posixDaySeconds :: (Num a) => a posixDaySeconds = 86400 posixDayPicoseconds :: Integer posixDayPicoseconds = posixDaySeconds * secondPicoseconds unixEpochMJD :: ModJulianDay unixEpochMJD = 40587 posixPicosecondsToUTCTime :: Integer -> UTCTime posixPicosecondsToUTCTime i = let (d,t) = divMod i posixDayPicoseconds in UTCTime (d + unixEpochMJD) (fromInteger t) utcTimeToPOSIXPicoseconds :: UTCTime -> Integer utcTimeToPOSIXPicoseconds (UTCTime d t) = ((d - unixEpochMJD) * posixDayPicoseconds) + min posixDayPicoseconds (toInteger t) addUTCTime :: UTCDiffTime -> UTCTime -> UTCTime addUTCTime x t = posixPicosecondsToUTCTime ((toInteger x) + (utcTimeToPOSIXPicoseconds t)) diffUTCTime :: UTCTime -> UTCTime -> UTCDiffTime diffUTCTime a b = fromInteger ((utcTimeToPOSIXPicoseconds a) - (utcTimeToPOSIXPicoseconds b)) -- Get current time data CTimeval = MkCTimeval CLong CLong ctimevalToPosixPicoseconds :: CTimeval -> Integer ctimevalToPosixPicoseconds (MkCTimeval s mus) = ((fromIntegral s) * 1000000 + (fromIntegral mus)) * 1000000 instance Storable CTimeval where sizeOf _ = (sizeOf (undefined :: CLong)) * 2 alignment _ = alignment (undefined :: CLong) peek p = do s <- peekElemOff (castPtr p) 0 mus <- peekElemOff (castPtr p) 1 return (MkCTimeval s mus) poke p (MkCTimeval s mus) = do pokeElemOff (castPtr p) 0 s pokeElemOff (castPtr p) 1 mus foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt getCurrentTime :: IO UTCTime getCurrentTime = with (MkCTimeval 0 0) (\ptval -> do result <- gettimeofday ptval nullPtr if (result == 0) then do tval <- peek ptval return (posixPicosecondsToUTCTime (ctimevalToPosixPicoseconds tval)) else fail ("error in gettimeofday: " ++ (show result)) )