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

[Ashley Yakeley]

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