System.Time.Clock Implementation - Clock.hs (1/1)

Ashley Yakeley ashley at semantic.org
Wed Feb 23 21:42:29 EST 2005

```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.

--
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,

-- 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))
)

```