X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FTime.hsc;h=74293eeeb60a5b68315ae1a4fae9b4b8c85d64a1;hb=69b2983d1ef10fefe155db9f777b9201e4c5b447;hp=e5cf6b0fe380d4f627b083f505a6433347ec76f2;hpb=260e7f2ed9a43c6ecf5a556d77817f39ed2893ab;p=haskell-directory.git diff --git a/System/Time.hsc b/System/Time.hsc index e5cf6b0..74293ee 100644 --- a/System/Time.hsc +++ b/System/Time.hsc @@ -1,28 +1,23 @@ ----------------------------------------------------------------------------- --- +-- | -- Module : System.Time -- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/core/LICENSE) +-- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- --- $Id: Time.hsc,v 1.6 2001/12/21 15:07:26 simonmar Exp $ --- --- The standard Time library. --- +-- The standard Time library, providing standard functionality for clock +-- times, including timezone information (i.e, the functionality of +-- \"@time.h@\", adapted to the Haskell environment). It follows RFC +-- 1129 in its use of Coordinated Universal Time (UTC). ----------------------------------------------------------------------------- {- Haskell 98 Time of Day Library ------------------------------ -The Time library provides standard functionality for clock times, -including timezone information (i.e, the functionality of "time.h", -adapted to the Haskell environment), It follows RFC 1129 in its use of -Coordinated Universal Time (UTC). - 2000/06/17 : RESTRICTIONS: * min./max. time diff currently is restricted to @@ -71,15 +66,16 @@ TODO: module System.Time ( - Month(..) - , Day(..) + -- * Clock times - , ClockTime(..) -- non-standard, lib. report gives this as abstract + ClockTime(..) -- non-standard, lib. report gives this as abstract -- instance Eq, Ord -- instance Show (non-standard) , getClockTime + -- * Time differences + , TimeDiff(..) , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.) , diffClockTimes @@ -89,7 +85,11 @@ module System.Time , timeDiffToString -- non-standard , formatTimeDiff -- non-standard + -- * Calendar times + , CalendarTime(..) + , Month(..) + , Day(..) , toCalendarTime , toUTCTime , toClockTime @@ -98,36 +98,60 @@ module System.Time ) where -#include "HsCore.h" +#ifdef __GLASGOW_HASKELL__ +#include "HsBase.h" +#endif + +#ifdef __NHC__ +#include +# if defined(__sun) || defined(__CYGWIN32__) +# define HAVE_TZNAME 1 +# else +# define HAVE_TM_ZONE 1 +# endif +import Ix +#endif import Prelude import Data.Ix import System.Locale import System.IO.Unsafe - + +#ifdef __HUGS__ +import Hugs.Time ( getClockTimePrim, toCalTimePrim, toClockTimePrim ) +#else import Foreign import Foreign.C +#endif -- One way to partition and give name to chunks of a year and a week: +-- | A month of the year. + data Month = January | February | March | April | May | June | July | August | September | October | November | December deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) +-- | A day of the week. + data Day = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) --- @ClockTime@ is an abstract type, used for the internal clock time. +-- | A representation of the internal clock time. -- Clock times may be compared, converted to strings, or converted to an --- external calendar time @CalendarTime@. - -data ClockTime = TOD Integer -- Seconds since 00:00:00 on 1 Jan 1970 - Integer -- Picoseconds with the specified second +-- external calendar time 'CalendarTime' for I\/O or other manipulations. + +data ClockTime = TOD Integer Integer + -- ^ Construct a clock time. The arguments are a number + -- of seconds since 00:00:00 (UTC) on 1 January 1970, + -- and an additional number of picoseconds. + -- + -- In Haskell 98, the 'ClockTime' type is abstract. deriving (Eq, Ord) -- When a ClockTime is shown, it is converted to a CalendarTime in the current @@ -139,49 +163,47 @@ instance Show ClockTime where (unsafePerformIO (toCalendarTime t))) {- -@CalendarTime@ is a user-readable and manipulable -representation of the internal $ClockTime$ type. The -numeric fields have the following ranges. +The numeric fields have the following ranges. \begin{verbatim} Value Range Comments ----- ----- -------- year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate] -mon 0 .. 11 [Jan = 0, Dec = 11] day 1 .. 31 hour 0 .. 23 min 0 .. 59 sec 0 .. 61 [Allows for two leap seconds] picosec 0 .. (10^12)-1 [This could be over-precise?] -wday 0 .. 6 [Sunday = 0, Saturday = 6] yday 0 .. 365 [364 in non-Leap years] tz -43200 .. 43200 [Variation from UTC in seconds] \end{verbatim} - -The {\em tzname} field is the name of the time zone. The {\em isdst} -field indicates whether Daylight Savings Time would be in effect. -} +-- | 'CalendarTime' is a user-readable and manipulable +-- representation of the internal 'ClockTime' type. + data CalendarTime = CalendarTime { - ctYear :: Int, - ctMonth :: Month, - ctDay :: Int, - ctHour :: Int, - ctMin :: Int, - ctSec :: Int, - ctPicosec :: Integer, - ctWDay :: Day, - ctYDay :: Int, - ctTZName :: String, - ctTZ :: Int, - ctIsDST :: Bool + ctYear :: Int -- ^ Year (pre-Gregorian dates are inaccurate) + , ctMonth :: Month -- ^ Month of the year + , ctDay :: Int -- ^ Day of the month (1 to 31) + , ctHour :: Int -- ^ Hour of the day (0 to 23) + , ctMin :: Int -- ^ Minutes (0 to 59) + , ctSec :: Int -- ^ Seconds (0 to 61, allowing for up to + -- two leap seconds) + , ctPicosec :: Integer -- ^ Picoseconds + , ctWDay :: Day -- ^ Day of the week + , ctYDay :: Int -- ^ Day of the year + -- (0 to 364, or 365 in leap years) + , ctTZName :: String -- ^ Name of the time zone + , ctTZ :: Int -- ^ Variation from UTC in seconds + , ctIsDST :: Bool -- ^ 'True' if Daylight Savings Time would + -- be in effect, and 'False' otherwise } deriving (Eq,Ord,Read,Show) --- The @TimeDiff@ type records the difference between two clock times in --- a user-readable way. +-- | records the difference between two clock times in a user-readable way. data TimeDiff = TimeDiff { @@ -195,40 +217,50 @@ data TimeDiff } deriving (Eq,Ord,Read,Show) +-- | null time difference. + noTimeDiff :: TimeDiff noTimeDiff = TimeDiff 0 0 0 0 0 0 0 -- ----------------------------------------------------------------------------- --- getClockTime returns the current time in its internal representation. +-- | returns the current time in its internal representation. -#if HAVE_GETTIMEOFDAY +getClockTime :: IO ClockTime +#ifdef __HUGS__ getClockTime = do + (sec,usec) <- getClockTimePrim + return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000)) + +#elif HAVE_GETTIMEOFDAY +getClockTime = do + let realToInteger = round . realToFrac :: Real a => a -> Integer allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime - return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000)) + return (TOD (realToInteger sec) ((realToInteger usec) * 1000000)) #elif HAVE_FTIME getClockTime = do + let realToInteger = round . realToFrac :: Real a => a -> Integer allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do ftime p_timeb sec <- (#peek struct timeb,time) p_timeb :: IO CTime msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort - return (TOD (fromIntegral sec) (fromIntegral msec * 1000000000)) + return (TOD (realToInteger sec) (fromIntegral msec * 1000000000)) #else /* use POSIX time() */ getClockTime = do secs <- time nullPtr -- can't fail, according to POSIX - return (TOD (fromIntegral secs) 0) + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (TOD (realToInteger secs) 0) #endif -- ----------------------------------------------------------------------------- --- addToClockTime d t adds a time difference d and a --- clock time t to yield a new clock time. The difference d --- may be either positive or negative. diffClockTimes t1 t2 returns --- the difference between two clock times t1 and t2 as a TimeDiff. +-- | @'addToClockTime' d t@ adds a time difference @d@ and a +-- clock time @t@ to yield a new clock time. The difference @d@ +-- may be either positive or negative. addToClockTime :: TimeDiff -> ClockTime -> ClockTime addToClockTime (TimeDiff year mon day hour min sec psec) @@ -241,7 +273,9 @@ addToClockTime (TimeDiff year mon day hour min sec psec) cal = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec)) -- FIXME! ^^^^ new_mon = fromEnum (ctMonth cal) + r_mon - (month', yr_diff) + month' = fst tmp + yr_diff = snd tmp + tmp | new_mon < 0 = (toEnum (12 + new_mon), (-1)) | new_mon > 11 = (toEnum (new_mon `mod` 12), 1) | otherwise = (toEnum new_mon, 0) @@ -252,6 +286,9 @@ addToClockTime (TimeDiff year mon day hour min sec psec) in toClockTime cal{ctMonth=month', ctYear=year'} +-- | @'diffClockTimes' t1 t2@ returns the difference between two clock +-- times @t1@ and @t2@ as a 'TimeDiff'. + diffClockTimes :: ClockTime -> ClockTime -> TimeDiff -- diffClockTimes is meant to be the dual to `addToClockTime'. -- If you want to have the TimeDiff properly splitted, use @@ -265,6 +302,8 @@ diffClockTimes (TOD sa pa) (TOD sb pb) = } +-- | converts a time difference to normal form. + normalizeTimeDiff :: TimeDiff -> TimeDiff -- FIXME: handle psecs properly -- FIXME: ?should be called by formatTimeDiff automagically? @@ -298,6 +337,7 @@ normalizeTimeDiff td = , tdSec = diffSecs } +#ifndef __HUGS__ -- ----------------------------------------------------------------------------- -- How do we deal with timezones on this architecture? @@ -313,16 +353,14 @@ gmtoff x = (#peek struct tm,tm_gmtoff) x #else /* ! HAVE_TM_ZONE */ # if HAVE_TZNAME || defined(_WIN32) -# if cygwin32_TARGET_OS +# if cygwin32_HOST_OS # define tzname _tzname # endif -# ifndef mingw32_TARGET_OS -foreign label tzname :: Ptr (Ptr CChar) +# ifndef mingw32_HOST_OS +foreign import ccall unsafe "time.h &tzname" tzname :: Ptr (Ptr CChar) # else -foreign import "ghcTimezone" unsafe timezone :: Ptr CLong -foreign import "ghcTzname" unsafe tzname :: Ptr (Ptr CChar) -# def inline long *ghcTimezone(void) { return &_timezone; } -# def inline char **ghcTzname(void) { return _tzname; } +foreign import ccall unsafe "__hscore_timezone" timezone :: Ptr CLong +foreign import ccall unsafe "__hscore_tzname" tzname :: Ptr (Ptr CChar) # endif zone x = do dst <- (#peek struct tm,tm_isdst) x @@ -333,49 +371,86 @@ zone x = do # endif /* ! HAVE_TZNAME */ -- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */ -#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS) -#define timezone _timezone -#endif - -# if HAVE_ALTZONE -foreign label altzone :: Ptr CTime -foreign label timezone :: Ptr CTime +# if HAVE_DECL_ALTZONE +foreign import ccall "&altzone" altzone :: Ptr CTime +foreign import ccall "&timezone" timezone :: Ptr CTime gmtoff x = do dst <- (#peek struct tm,tm_isdst) x tz <- if dst then peek altzone else peek timezone - return (fromIntegral tz) -# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone ) -# else /* ! HAVE_ALTZONE */ + let realToInteger = round . realToFrac :: Real a => a -> Integer + return (-fromIntegral (realToInteger tz)) +# else /* ! HAVE_DECL_ALTZONE */ + +#if !defined(mingw32_HOST_OS) +foreign import ccall "time.h &timezone" timezone :: Ptr CLong +#endif + -- Assume that DST offset is 1 hour ... gmtoff x = do dst <- (#peek struct tm,tm_isdst) x tz <- peek timezone - if dst then return (fromIntegral tz - 3600) else return tz -# endif /* ! HAVE_ALTZONE */ + -- According to the documentation for tzset(), + -- http://www.opengroup.org/onlinepubs/007908799/xsh/tzset.html + -- timezone offsets are > 0 west of the Prime Meridian. + -- + -- This module assumes the interpretation of tm_gmtoff, i.e., offsets + -- are > 0 East of the Prime Meridian, so flip the sign. + return (- (if dst then (fromIntegral tz - 3600) else tz)) +# endif /* ! HAVE_DECL_ALTZONE */ #endif /* ! HAVE_TM_ZONE */ +#endif /* ! __HUGS__ */ -- ----------------------------------------------------------------------------- --- toCalendarTime t converts t to a local time, modified by --- the current timezone and daylight savings time settings. toUTCTime --- t converts t into UTC time. toClockTime l converts l into the --- corresponding internal ClockTime. The wday, yday, tzname, and isdst fields --- are ignored. - +-- | converts an internal clock time to a local time, modified by the +-- timezone and daylight savings time settings in force at the time +-- of conversion. Because of this dependence on the local environment, +-- 'toCalendarTime' is in the 'IO' monad. toCalendarTime :: ClockTime -> IO CalendarTime -#if HAVE_LOCALTIME_R +#ifdef __HUGS__ +toCalendarTime = toCalTime False +#elif HAVE_LOCALTIME_R toCalendarTime = clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False #else toCalendarTime = clockToCalendarTime_static localtime False #endif -toUTCTime :: ClockTime -> CalendarTime -#if HAVE_GMTIME_R +-- | converts an internal clock time into a 'CalendarTime' in standard +-- UTC format. + +toUTCTime :: ClockTime -> CalendarTime +#ifdef __HUGS__ +toUTCTime = unsafePerformIO . toCalTime True +#elif HAVE_GMTIME_R toUTCTime = unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True #else toUTCTime = unsafePerformIO . clockToCalendarTime_static gmtime True #endif +#ifdef __HUGS__ +toCalTime :: Bool -> ClockTime -> IO CalendarTime +toCalTime toUTC (TOD s psecs) + | (s > fromIntegral (maxBound :: Int)) || + (s < fromIntegral (minBound :: Int)) + = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++ + "clock secs out of range") + | otherwise = do + (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <- + toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s) + return (CalendarTime{ ctYear=1900+year + , ctMonth=toEnum mon + , ctDay=mday + , ctHour=hour + , ctMin=min + , ctSec=sec + , ctPicosec=psecs + , ctWDay=toEnum wday + , ctYDay=yday + , ctTZName=(if toUTC then "UTC" else zone) + , ctTZ=(if toUTC then 0 else off) + , ctIsDST=not toUTC && (isdst/=0) + }) +#else /* ! __HUGS__ */ throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm)) -> (Ptr CTime -> Ptr CTm -> IO ( )) throwAwayReturnPointer fun x y = fun x y >> return () @@ -383,14 +458,14 @@ throwAwayReturnPointer fun x y = fun x y >> return () clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime -> IO CalendarTime clockToCalendarTime_static fun is_utc (TOD secs psec) = do - withObject (fromIntegral secs :: CTime) $ \ p_timer -> do + with (fromIntegral secs :: CTime) $ \ p_timer -> do p_tm <- fun p_timer -- can't fail, according to POSIX clockToCalendarTime_aux is_utc p_tm psec clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime -> IO CalendarTime clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do - withObject (fromIntegral secs :: CTime) $ \ p_timer -> do + with (fromIntegral secs :: CTime) $ \ p_timer -> do allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do fun p_timer p_tm clockToCalendarTime_aux is_utc p_tm psec @@ -427,9 +502,20 @@ clockToCalendarTime_aux is_utc p_tm psec = do (if is_utc then "UTC" else tzname) (if is_utc then 0 else fromIntegral tz) (if is_utc then False else isdst /= 0)) +#endif /* ! __HUGS__ */ +-- | converts a 'CalendarTime' into the corresponding internal +-- 'ClockTime', ignoring the contents of the 'ctWDay', 'ctYDay', +-- 'ctTZName' and 'ctIsDST' fields. toClockTime :: CalendarTime -> ClockTime +#ifdef __HUGS__ +toClockTime (CalendarTime yr mon mday hour min sec psec + _wday _yday _tzname tz _isdst) = + unsafePerformIO $ do + s <- toClockTimePrim (yr-1900) (fromEnum mon) mday hour min sec tz + return (TOD (fromIntegral s) psec) +#else /* ! __HUGS__ */ toClockTime (CalendarTime year mon mday hour min sec psec _wday _yday _tzname tz isdst) = @@ -469,15 +555,23 @@ toClockTime (CalendarTime year mon mday hour min sec psec -- result. -- gmtoff <- gmtoff p_tm - let res = fromIntegral t - tz + fromIntegral gmtoff - return (TOD (fromIntegral res) psec) + let realToInteger = round . realToFrac :: Real a => a -> Integer + res = realToInteger t - fromIntegral tz + fromIntegral gmtoff + return (TOD res psec) +#endif /* ! __HUGS__ */ -- ----------------------------------------------------------------------------- -- Converting time values to strings. +-- | formats calendar times using local conventions. + calendarTimeToString :: CalendarTime -> String calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" +-- | formats calendar times using local conventions and a formatting string. +-- The formatting string is that understood by the ISO C @strftime()@ +-- function. + formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String formatCalendarTime l fmt (CalendarTime year mon day hour min sec _ wday yday tzname _ _) = @@ -549,16 +643,21 @@ show2' x where x' = x `rem` 100 show3 x = show (x `quot` 100) ++ show2 (x `rem` 100) - where x' = x `rem` 1000 to12 :: Int -> Int to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h' -- Useful extensions for formatting TimeDiffs. +-- | formats time differences using local conventions. + timeDiffToString :: TimeDiff -> String timeDiffToString = formatTimeDiff defaultTimeLocale "%c" +-- | formats time differences using local conventions and a formatting string. +-- The formatting string is that understood by the ISO C @strftime()@ +-- function. + formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _) = doFmt fmt @@ -612,35 +711,43 @@ formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _) addS v s = if abs v == 1 then fst s else snd s - +#ifndef __HUGS__ -- ----------------------------------------------------------------------------- -- Foreign time interface (POSIX) type CTm = () -- struct tm #if HAVE_LOCALTIME_R -foreign import unsafe localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) +foreign import ccall unsafe "time.h localtime_r" + localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) #else -foreign import unsafe localtime :: Ptr CTime -> IO (Ptr CTm) +foreign import ccall unsafe "time.h localtime" + localtime :: Ptr CTime -> IO (Ptr CTm) #endif #if HAVE_GMTIME_R -foreign import unsafe gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) +foreign import ccall unsafe "time.h gmtime_r" + gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) #else -foreign import unsafe gmtime :: Ptr CTime -> IO (Ptr CTm) +foreign import ccall unsafe "time.h gmtime" + gmtime :: Ptr CTime -> IO (Ptr CTm) #endif -foreign import unsafe mktime :: Ptr CTm -> IO CTime -foreign import unsafe time :: Ptr CTime -> IO CTime +foreign import ccall unsafe "time.h mktime" + mktime :: Ptr CTm -> IO CTime +foreign import ccall unsafe "time.h time" + time :: Ptr CTime -> IO CTime #if HAVE_GETTIMEOFDAY type CTimeVal = () -foreign import unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt +foreign import ccall unsafe "time.h gettimeofday" + gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt #endif #if HAVE_FTIME type CTimeB = () -#ifndef mingw32_TARGET_OS -foreign import unsafe ftime :: Ptr CTimeB -> IO CInt +#ifndef mingw32_HOST_OS +foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO CInt #else -foreign import unsafe ftime :: Ptr CTimeB -> IO () +foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO () #endif #endif +#endif /* ! __HUGS__ */