System/Time.hsc

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  System.Time
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- The standard Time library, providing standard functionality for clock
  12 -- times, including timezone information (i.e, the functionality of
  13 -- \"@time.h@\", adapted to the Haskell environment).  It follows RFC
  14 -- 1129 in its use of Coordinated Universal Time (UTC).
  15 -----------------------------------------------------------------------------
  16
  17 {-
  18 Haskell 98 Time of Day Library
  19 ------------------------------
  20
  21 2000/06/17 <michael.weber@post.rwth-aachen.de>:
  22 RESTRICTIONS:
  23   * min./max. time diff currently is restricted to
  24     [minBound::Int, maxBound::Int]
  25
  26   * surely other restrictions wrt. min/max bounds
  27
  28
  29 NOTES:
  30   * printing times
  31
  32     `showTime' (used in `instance Show ClockTime') always prints time
  33     converted to the local timezone (even if it is taken from
  34     `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
  35     honors the tzone & tz fields and prints UTC or whatever timezone
  36     is stored inside CalendarTime.
  37
  38     Maybe `showTime' should be changed to use UTC, since it would
  39     better correspond to the actual representation of `ClockTime'
  40     (can be done by replacing localtime(3) by gmtime(3)).
  41
  42
  43 BUGS:
  44   * add proper handling of microsecs, currently, they're mostly
  45     ignored
  46
  47   * `formatFOO' case of `%s' is currently broken...
  48
  49
  50 TODO:
  51   * check for unusual date cases, like 1970/1/1 00:00h, and conversions
  52     between different timezone's etc.
  53
  54   * check, what needs to be in the IO monad, the current situation
  55     seems to be a bit inconsistent to me
  56
  57   * check whether `isDst = -1' works as expected on other arch's
  58     (Solaris anyone?)
  59
  60   * add functions to parse strings to `CalendarTime' (some day...)
  61
  62   * implement padding capabilities ("%_", "%-") in `formatFOO'
  63
  64   * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
  65 -}
  66
  67 module System.Time
  68      (
  69         -- * Clock times
  70
  71         ClockTime(..) -- non-standard, lib. report gives this as abstract
  72         -- instance Eq, Ord
  73         -- instance Show (non-standard)
  74
  75      ,  getClockTime
  76
  77         -- * Time differences
  78
  79      ,  TimeDiff(..)
  80      ,  noTimeDiff      -- non-standard (but useful when constructing TimeDiff vals.)
  81      ,  diffClockTimes
  82      ,  addToClockTime
  83
  84      ,  normalizeTimeDiff -- non-standard
  85      ,  timeDiffToString  -- non-standard
  86      ,  formatTimeDiff    -- non-standard
  87
  88         -- * Calendar times
  89
  90      ,  CalendarTime(..)
  91      ,  Month(..)
  92      ,  Day(..)
  93      ,  toCalendarTime
  94      ,  toUTCTime
  95      ,  toClockTime
  96      ,  calendarTimeToString
  97      ,  formatCalendarTime
  98
  99      ) where
 100
 101 #ifdef __GLASGOW_HASKELL__
 102 #include "HsBase.h"
 103 #endif
 104
 105 #ifdef __NHC__
 106 #include <time.h>
 107 #  if defined(__sun) || defined(__CYGWIN32__)
 108 #    define HAVE_TZNAME 1
 109 #  else
 110 #    define HAVE_TM_ZONE 1
 111 #  endif
 112 import Ix
 113 #endif
 114
 115 import Prelude
 116
 117 import Data.Ix
 118 import System.Locale
 119 import System.IO.Unsafe
 120
 121 #ifdef __HUGS__
 122 import Hugs.Time ( getClockTimePrim, toCalTimePrim, toClockTimePrim )
 123 #else
 124 import Foreign
 125 import Foreign.C
 126 #endif
 127
 128 -- One way to partition and give name to chunks of a year and a week:
 129
 130 -- | A month of the year.
 131
 132 data Month
 133  = January   | February | March    | April
 134  | May       | June     | July     | August
 135  | September | October  | November | December
 136  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
 137
 138 -- | A day of the week.
 139
 140 data Day
 141  = Sunday   | Monday | Tuesday | Wednesday
 142  | Thursday | Friday | Saturday
 143  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
 144
 145 -- | A representation of the internal clock time.
 146 -- Clock times may be compared, converted to strings, or converted to an
 147 -- external calendar time 'CalendarTime' for I\/O or other manipulations.
 148
 149 data ClockTime = TOD Integer Integer
 150                 -- ^ Construct a clock time.  The arguments are a number
 151                 -- of seconds since 00:00:00 (UTC) on 1 January 1970,
 152                 -- and an additional number of picoseconds.
 153                 --
 154                 -- In Haskell 98, the 'ClockTime' type is abstract.
 155                deriving (Eq, Ord)
 156
 157 -- When a ClockTime is shown, it is converted to a CalendarTime in the current
 158 -- timezone and then printed.  FIXME: This is arguably wrong, since we can't
 159 -- get the current timezone without being in the IO monad.
 160
 161 instance Show ClockTime where
 162     showsPrec _ t = showString (calendarTimeToString
 163                                  (unsafePerformIO (toCalendarTime t)))
 164
 165 {-
 166 The numeric fields have the following ranges.
 167
 168 \begin{verbatim}
 169 Value         Range             Comments
 170 -----         -----             --------
 171
 172 year    -maxInt .. maxInt       [Pre-Gregorian dates are inaccurate]
 173 day           1 .. 31
 174 hour          0 .. 23
 175 min           0 .. 59
 176 sec           0 .. 61           [Allows for two leap seconds]
 177 picosec       0 .. (10^12)-1    [This could be over-precise?]
 178 yday          0 .. 365          [364 in non-Leap years]
 179 tz       -43200 .. 43200        [Variation from UTC in seconds]
 180 \end{verbatim}
 181 -}
 182
 183 -- | 'CalendarTime' is a user-readable and manipulable
 184 -- representation of the internal 'ClockTime' type.
 185
 186 data CalendarTime
 187  = CalendarTime  {
 188        ctYear    :: Int         -- ^ Year (pre-Gregorian dates are inaccurate)
 189      , ctMonth   :: Month       -- ^ Month of the year
 190      , ctDay     :: Int         -- ^ Day of the month (1 to 31)
 191      , ctHour    :: Int         -- ^ Hour of the day (0 to 23)
 192      , ctMin     :: Int         -- ^ Minutes (0 to 59)
 193      , ctSec     :: Int         -- ^ Seconds (0 to 61, allowing for up to
 194                                 -- two leap seconds)
 195      , ctPicosec :: Integer     -- ^ Picoseconds
 196      , ctWDay    :: Day         -- ^ Day of the week
 197      , ctYDay    :: Int         -- ^ Day of the year
 198                                 -- (0 to 364, or 365 in leap years)
 199      , ctTZName  :: String      -- ^ Name of the time zone
 200      , ctTZ      :: Int         -- ^ Variation from UTC in seconds
 201      , ctIsDST   :: Bool        -- ^ 'True' if Daylight Savings Time would
 202                                 -- be in effect, and 'False' otherwise
 203  }
 204  deriving (Eq,Ord,Read,Show)
 205
 206 -- | records the difference between two clock times in a user-readable way.
 207
 208 data TimeDiff
 209  = TimeDiff {
 210      tdYear    :: Int,
 211      tdMonth   :: Int,
 212      tdDay     :: Int,
 213      tdHour    :: Int,
 214      tdMin     :: Int,
 215      tdSec     :: Int,
 216      tdPicosec :: Integer -- not standard
 217    }
 218    deriving (Eq,Ord,Read,Show)
 219
 220 -- | null time difference.
 221
 222 noTimeDiff :: TimeDiff
 223 noTimeDiff = TimeDiff 0 0 0 0 0 0 0
 224
 225 -- -----------------------------------------------------------------------------
 226 -- | returns the current time in its internal representation.
 227
 228 getClockTime :: IO ClockTime
 229 #ifdef __HUGS__
 230 getClockTime = do
 231   (sec,usec) <- getClockTimePrim
 232   return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000))
 233
 234 #elif HAVE_GETTIMEOFDAY
 235 getClockTime = do
 236   let realToInteger = round . realToFrac :: Real a => a -> Integer
 237   allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
 238     throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
 239     sec  <- (#peek struct timeval,tv_sec)  p_timeval :: IO CTime
 240     usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime
 241     return (TOD (realToInteger sec) ((realToInteger usec) * 1000000))
 242
 243 #elif HAVE_FTIME
 244 getClockTime = do
 245   let realToInteger = round . realToFrac :: Real a => a -> Integer
 246   allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do
 247   ftime p_timeb
 248   sec  <- (#peek struct timeb,time) p_timeb :: IO CTime
 249   msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort
 250   return (TOD (realToInteger sec) (fromIntegral msec * 1000000000))
 251
 252 #else /* use POSIX time() */
 253 getClockTime = do
 254     secs <- time nullPtr -- can't fail, according to POSIX
 255     let realToInteger = round . realToFrac :: Real a => a -> Integer
 256     return (TOD (realToInteger secs) 0)
 257
 258 #endif
 259
 260 -- -----------------------------------------------------------------------------
 261 -- | @'addToClockTime' d t@ adds a time difference @d@ and a
 262 -- clock time @t@ to yield a new clock time.  The difference @d@
 263 -- may be either positive or negative.
 264
 265 addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime
 266 addToClockTime (TimeDiff year mon day hour min sec psec)
 267                (TOD c_sec c_psec) =
 268         let
 269           sec_diff = toInteger sec +
 270                      60 * toInteger min +
 271                      3600 * toInteger hour +
 272                      24 * 3600 * toInteger day
 273           (d_sec, d_psec) = (c_psec + psec) `quotRem` 1000000000000
 274           cal      = toUTCTime (TOD (c_sec + sec_diff + d_sec) d_psec)
 275           new_mon  = fromEnum (ctMonth cal) + r_mon
 276           month' = fst tmp
 277           yr_diff = snd tmp
 278           tmp
 279             | new_mon < 0  = (toEnum (12 + new_mon), (-1))
 280             | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
 281             | otherwise    = (toEnum new_mon, 0)
 282
 283           (r_yr, r_mon) = mon `quotRem` 12
 284
 285           year' = ctYear cal + year + r_yr + yr_diff
 286         in
 287         toClockTime cal{ctMonth=month', ctYear=year'}
 288
 289 -- | @'diffClockTimes' t1 t2@ returns the difference between two clock
 290 -- times @t1@ and @t2@ as a 'TimeDiff'.
 291
 292 diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff
 293 -- diffClockTimes is meant to be the dual to `addToClockTime'.
 294 -- If you want to have the TimeDiff properly splitted, use
 295 -- `normalizeTimeDiff' on this function's result
 296 --
 297 -- CAVEAT: see comment of normalizeTimeDiff
 298 diffClockTimes (TOD sa pa) (TOD sb pb) =
 299     noTimeDiff{ tdSec     = fromIntegral (sa - sb)
 300                 -- FIXME: can handle just 68 years...
 301               , tdPicosec = pa - pb
 302               }
 303
 304
 305 -- | converts a time difference to normal form.
 306
 307 normalizeTimeDiff :: TimeDiff -> TimeDiff
 308 -- FIXME: handle psecs properly
 309 -- FIXME: ?should be called by formatTimeDiff automagically?
 310 --
 311 -- when applied to something coming out of `diffClockTimes', you loose
 312 -- the duality to `addToClockTime', since a year does not always have
 313 -- 365 days, etc.
 314 --
 315 -- apply this function as late as possible to prevent those "rounding"
 316 -- errors
 317 normalizeTimeDiff td =
 318   let
 319       rest0 = toInteger (tdSec td)
 320                + 60 * (toInteger (tdMin td)
 321                     + 60 * (toInteger (tdHour td)
 322                          + 24 * (toInteger (tdDay td)
 323                               + 30 * toInteger (tdMonth td)
 324                               + 365 * toInteger (tdYear td))))
 325
 326       (diffYears,  rest1)    = rest0 `quotRem` (365 * 24 * 3600)
 327       (diffMonths, rest2)    = rest1 `quotRem` (30 * 24 * 3600)
 328       (diffDays,   rest3)    = rest2 `quotRem` (24 * 3600)
 329       (diffHours,  rest4)    = rest3 `quotRem` 3600
 330       (diffMins,   diffSecs) = rest4 `quotRem` 60
 331   in
 332       td{ tdYear  = fromInteger diffYears
 333         , tdMonth = fromInteger diffMonths
 334         , tdDay   = fromInteger diffDays
 335         , tdHour  = fromInteger diffHours
 336         , tdMin   = fromInteger diffMins
 337         , tdSec   = fromInteger diffSecs
 338         }
 339
 340 #ifndef __HUGS__
 341 -- -----------------------------------------------------------------------------
 342 -- How do we deal with timezones on this architecture?
 343
 344 -- The POSIX way to do it is through the global variable tzname[].
 345 -- But that's crap, so we do it The BSD Way if we can: namely use the
 346 -- tm_zone and tm_gmtoff fields of struct tm, if they're available.
 347
 348 zone   :: Ptr CTm -> IO (Ptr CChar)
 349 gmtoff :: Ptr CTm -> IO CLong
 350 #if HAVE_TM_ZONE
 351 zone x      = (#peek struct tm,tm_zone) x
 352 gmtoff x    = (#peek struct tm,tm_gmtoff) x
 353
 354 #else /* ! HAVE_TM_ZONE */
 355 # if HAVE_TZNAME || defined(_WIN32)
 356 #  if cygwin32_HOST_OS
 357 #   define tzname _tzname
 358 #  endif
 359 #  ifndef mingw32_HOST_OS
 360 foreign import ccall unsafe "time.h &tzname" tzname :: Ptr CString
 361 #  else
 362 foreign import ccall unsafe "__hscore_timezone" timezone :: Ptr CLong
 363 foreign import ccall unsafe "__hscore_tzname"   tzname :: Ptr CString
 364 #  endif
 365 zone x = do
 366   dst <- (#peek struct tm,tm_isdst) x
 367   if dst then peekElemOff tzname 1 else peekElemOff tzname 0
 368 # else /* ! HAVE_TZNAME */
 369 -- We're in trouble. If you should end up here, please report this as a bug.
 370 #  error "Don't know how to get at timezone name on your OS."
 371 # endif /* ! HAVE_TZNAME */
 372
 373 -- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
 374 # if HAVE_DECL_ALTZONE
 375 foreign import ccall "&altzone"  altzone  :: Ptr CTime
 376 foreign import ccall "&timezone" timezone :: Ptr CTime
 377 gmtoff x = do
 378   dst <- (#peek struct tm,tm_isdst) x
 379   tz <- if dst then peek altzone else peek timezone
 380   let realToInteger = round . realToFrac :: Real a => a -> Integer
 381   return (-fromIntegral (realToInteger tz))
 382 # else /* ! HAVE_DECL_ALTZONE */
 383
 384 #if !defined(mingw32_HOST_OS)
 385 foreign import ccall "time.h &timezone" timezone :: Ptr CLong
 386 #endif
 387
 388 -- Assume that DST offset is 1 hour ...
 389 gmtoff x = do
 390   dst <- (#peek struct tm,tm_isdst) x
 391   tz  <- peek timezone
 392    -- According to the documentation for tzset(),
 393    --   http://www.opengroup.org/onlinepubs/007908799/xsh/tzset.html
 394    -- timezone offsets are > 0 west of the Prime Meridian.
 395    --
 396    -- This module assumes the interpretation of tm_gmtoff, i.e., offsets
 397    -- are > 0 East of the Prime Meridian, so flip the sign.
 398   return (- (if dst then (fromIntegral tz - 3600) else tz))
 399 # endif /* ! HAVE_DECL_ALTZONE */
 400 #endif  /* ! HAVE_TM_ZONE */
 401 #endif /* ! __HUGS__ */
 402
 403 -- -----------------------------------------------------------------------------
 404 -- | converts an internal clock time to a local time, modified by the
 405 -- timezone and daylight savings time settings in force at the time
 406 -- of conversion.  Because of this dependence on the local environment,
 407 -- 'toCalendarTime' is in the 'IO' monad.
 408
 409 toCalendarTime :: ClockTime -> IO CalendarTime
 410 #ifdef __HUGS__
 411 toCalendarTime =  toCalTime False
 412 #elif HAVE_LOCALTIME_R
 413 toCalendarTime =  clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False
 414 #else
 415 toCalendarTime =  clockToCalendarTime_static localtime False
 416 #endif
 417
 418 -- | converts an internal clock time into a 'CalendarTime' in standard
 419 -- UTC format.
 420
 421 toUTCTime :: ClockTime -> CalendarTime
 422 #ifdef __HUGS__
 423 toUTCTime      =  unsafePerformIO . toCalTime True
 424 #elif HAVE_GMTIME_R
 425 toUTCTime      =  unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True
 426 #else
 427 toUTCTime      =  unsafePerformIO . clockToCalendarTime_static gmtime True
 428 #endif
 429
 430 #ifdef __HUGS__
 431 toCalTime :: Bool -> ClockTime -> IO CalendarTime
 432 toCalTime toUTC (TOD s psecs)
 433   | (s > fromIntegral (maxBound :: Int)) ||
 434     (s < fromIntegral (minBound :: Int))
 435   = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++
 436            "clock secs out of range")
 437   | otherwise = do
 438     (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <-
 439                 toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s)
 440     return (CalendarTime{ ctYear=1900+year
 441                         , ctMonth=toEnum mon
 442                         , ctDay=mday
 443                         , ctHour=hour
 444                         , ctMin=min
 445                         , ctSec=sec
 446                         , ctPicosec=psecs
 447                         , ctWDay=toEnum wday
 448                         , ctYDay=yday
 449                         , ctTZName=(if toUTC then "UTC" else zone)
 450                         , ctTZ=(if toUTC then 0 else off)
 451                         , ctIsDST=not toUTC && (isdst/=0)
 452                         })
 453 #else /* ! __HUGS__ */
 454 throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm))
 455                        -> (Ptr CTime -> Ptr CTm -> IO (       ))
 456 throwAwayReturnPointer fun x y = fun x y >> return ()
 457
 458 #if !HAVE_LOCALTIME_R || !HAVE_GMTIME_R
 459 clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
 460          -> IO CalendarTime
 461 clockToCalendarTime_static fun is_utc (TOD secs psec) = do
 462   with (fromIntegral secs :: CTime)  $ \ p_timer -> do
 463     p_tm <- fun p_timer         -- can't fail, according to POSIX
 464     clockToCalendarTime_aux is_utc p_tm psec
 465 #endif
 466
 467 #if HAVE_LOCALTIME_R || HAVE_GMTIME_R
 468 clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime
 469          -> IO CalendarTime
 470 clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do
 471   with (fromIntegral secs :: CTime)  $ \ p_timer -> do
 472     allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
 473       fun p_timer p_tm
 474       clockToCalendarTime_aux is_utc p_tm psec
 475 #endif
 476
 477 clockToCalendarTime_aux :: Bool -> Ptr CTm -> Integer -> IO CalendarTime
 478 clockToCalendarTime_aux is_utc p_tm psec = do
 479     sec   <-  (#peek struct tm,tm_sec  ) p_tm :: IO CInt
 480     min   <-  (#peek struct tm,tm_min  ) p_tm :: IO CInt
 481     hour  <-  (#peek struct tm,tm_hour ) p_tm :: IO CInt
 482     mday  <-  (#peek struct tm,tm_mday ) p_tm :: IO CInt
 483     mon   <-  (#peek struct tm,tm_mon  ) p_tm :: IO CInt
 484     year  <-  (#peek struct tm,tm_year ) p_tm :: IO CInt
 485     wday  <-  (#peek struct tm,tm_wday ) p_tm :: IO CInt
 486     yday  <-  (#peek struct tm,tm_yday ) p_tm :: IO CInt
 487     isdst <-  (#peek struct tm,tm_isdst) p_tm :: IO CInt
 488     zone  <-  zone p_tm
 489     tz    <-  gmtoff p_tm
 490
 491     tzname <- peekCString zone
 492
 493     let month  | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon)
 494                | otherwise             = error ("toCalendarTime: illegal month value: " ++ show mon)
 495
 496     return (CalendarTime
 497                 (1900 + fromIntegral year)
 498                 month
 499                 (fromIntegral mday)
 500                 (fromIntegral hour)
 501                 (fromIntegral min)
 502                 (fromIntegral sec)
 503                 psec
 504                 (toEnum (fromIntegral wday))
 505                 (fromIntegral yday)
 506                 (if is_utc then "UTC" else tzname)
 507                 (if is_utc then 0     else fromIntegral tz)
 508                 (if is_utc then False else isdst /= 0))
 509 #endif /* ! __HUGS__ */
 510
 511 -- | converts a 'CalendarTime' into the corresponding internal
 512 -- 'ClockTime', ignoring the contents of the  'ctWDay', 'ctYDay',
 513 -- 'ctTZName' and 'ctIsDST' fields.
 514
 515 toClockTime :: CalendarTime -> ClockTime
 516 #ifdef __HUGS__
 517 toClockTime (CalendarTime yr mon mday hour min sec psec
 518                           _wday _yday _tzname tz _isdst) =
 519   unsafePerformIO $ do
 520     s <- toClockTimePrim (yr-1900) (fromEnum mon) mday hour min sec tz
 521     return (TOD (fromIntegral s) psec)
 522 #else /* ! __HUGS__ */
 523 toClockTime (CalendarTime year mon mday hour min sec psec
 524                           _wday _yday _tzname tz isdst) =
 525
 526      -- `isDst' causes the date to be wrong by one hour...
 527      -- FIXME: check, whether this works on other arch's than Linux, too...
 528      --
 529      -- so we set it to (-1) (means `unknown') and let `mktime' determine
 530      -- the real value...
 531     let isDst = -1 :: CInt in   -- if isdst then (1::Int) else 0
 532
 533     if psec < 0 || psec > 999999999999 then
 534         error "Time.toClockTime: picoseconds out of range"
 535     else if tz < -43200 || tz > 43200 then
 536         error "Time.toClockTime: timezone offset out of range"
 537     else
 538       unsafePerformIO $ do
 539       allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
 540         (#poke struct tm,tm_sec  ) p_tm (fromIntegral sec  :: CInt)
 541         (#poke struct tm,tm_min  ) p_tm (fromIntegral min  :: CInt)
 542         (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
 543         (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)
 544         (#poke struct tm,tm_mon  ) p_tm (fromIntegral (fromEnum mon) :: CInt)
 545         (#poke struct tm,tm_year ) p_tm (fromIntegral year - 1900 :: CInt)
 546         (#poke struct tm,tm_isdst) p_tm isDst
 547         t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input")
 548                 (mktime p_tm)
 549         --
 550         -- mktime expects its argument to be in the local timezone, but
 551         -- toUTCTime makes UTC-encoded CalendarTime's ...
 552         --
 553         -- Since there is no any_tz_struct_tm-to-time_t conversion
 554         -- function, we have to fake one... :-) If not in all, it works in
 555         -- most cases (before, it was the other way round...)
 556         --
 557         -- Luckily, mktime tells us, what it *thinks* the timezone is, so,
 558         -- to compensate, we add the timezone difference to mktime's
 559         -- result.
 560         --
 561         gmtoff <- gmtoff p_tm
 562         let realToInteger = round . realToFrac :: Real a => a -> Integer
 563             res = realToInteger t - fromIntegral tz + fromIntegral gmtoff
 564         return (TOD res psec)
 565 #endif /* ! __HUGS__ */
 566
 567 -- -----------------------------------------------------------------------------
 568 -- Converting time values to strings.
 569
 570 -- | formats calendar times using local conventions.
 571
 572 calendarTimeToString  :: CalendarTime -> String
 573 calendarTimeToString  =  formatCalendarTime defaultTimeLocale "%c"
 574
 575 -- | formats calendar times using local conventions and a formatting string.
 576 -- The formatting string is that understood by the ISO C @strftime()@
 577 -- function.
 578
 579 formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
 580 formatCalendarTime l fmt (CalendarTime year mon day hour min sec _
 581                                        wday yday tzname _ _) =
 582         doFmt fmt
 583   where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
 584         doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
 585         doFmt ('%':c:cs)   = decode c ++ doFmt cs
 586         doFmt (c:cs) = c : doFmt cs
 587         doFmt "" = ""
 588
 589         decode 'A' = fst (wDays l  !! fromEnum wday) -- day of the week, full name
 590         decode 'a' = snd (wDays l  !! fromEnum wday) -- day of the week, abbrev.
 591         decode 'B' = fst (months l !! fromEnum mon)  -- month, full name
 592         decode 'b' = snd (months l !! fromEnum mon)  -- month, abbrev
 593         decode 'h' = snd (months l !! fromEnum mon)  -- ditto
 594         decode 'C' = show2 (year `quot` 100)         -- century
 595         decode 'c' = doFmt (dateTimeFmt l)           -- locale's data and time format.
 596         decode 'D' = doFmt "%m/%d/%y"
 597         decode 'd' = show2 day                       -- day of the month
 598         decode 'e' = show2' day                      -- ditto, padded
 599         decode 'H' = show2 hour                      -- hours, 24-hour clock, padded
 600         decode 'I' = show2 (to12 hour)               -- hours, 12-hour clock
 601         decode 'j' = show3 yday                      -- day of the year
 602         decode 'k' = show2' hour                     -- hours, 24-hour clock, no padding
 603         decode 'l' = show2' (to12 hour)              -- hours, 12-hour clock, no padding
 604         decode 'M' = show2 min                       -- minutes
 605         decode 'm' = show2 (fromEnum mon+1)          -- numeric month
 606         decode 'n' = "\n"
 607         decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
 608         decode 'R' = doFmt "%H:%M"
 609         decode 'r' = doFmt (time12Fmt l)
 610         decode 'T' = doFmt "%H:%M:%S"
 611         decode 't' = "\t"
 612         decode 'S' = show2 sec                       -- seconds
 613         decode 's' = show2 sec                       -- number of secs since Epoch. (ToDo.)
 614         decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
 615         decode 'u' = show (let n = fromEnum wday in  -- numeric day of the week (1=Monday, 7=Sunday)
 616                            if n == 0 then 7 else n)
 617         decode 'V' =                                 -- week number (as per ISO-8601.)
 618             let (week, days) =                       -- [yep, I've always wanted to be able to display that too.]
 619                    (yday + 7 - if fromEnum wday > 0 then
 620                                fromEnum wday - 1 else 6) `divMod` 7
 621             in  show2 (if days >= 4 then
 622                           week+1
 623                        else if week == 0 then 53 else week)
 624
 625         decode 'W' =                                 -- week number, weeks starting on monday
 626             show2 ((yday + 7 - if fromEnum wday > 0 then
 627                                fromEnum wday - 1 else 6) `div` 7)
 628         decode 'w' = show (fromEnum wday)            -- numeric day of the week, weeks starting on Sunday.
 629         decode 'X' = doFmt (timeFmt l)               -- locale's preferred way of printing time.
 630         decode 'x' = doFmt (dateFmt l)               -- locale's preferred way of printing dates.
 631         decode 'Y' = show year                       -- year, including century.
 632         decode 'y' = show2 (year `rem` 100)          -- year, within century.
 633         decode 'Z' = tzname                          -- timezone name
 634         decode '%' = "%"
 635         decode c   = [c]
 636
 637
 638 show2, show2', show3 :: Int -> String
 639 show2 x
 640  | x' < 10   = '0': show x'
 641  | otherwise = show x'
 642  where x' = x `rem` 100
 643
 644 show2' x
 645  | x' < 10   = ' ': show x'
 646  | otherwise = show x'
 647  where x' = x `rem` 100
 648
 649 show3 x = show (x `quot` 100) ++ show2 (x `rem` 100)
 650
 651 to12 :: Int -> Int
 652 to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
 653
 654 -- Useful extensions for formatting TimeDiffs.
 655
 656 -- | formats time differences using local conventions.
 657
 658 timeDiffToString :: TimeDiff -> String
 659 timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
 660
 661 -- | formats time differences using local conventions and a formatting string.
 662 -- The formatting string is that understood by the ISO C @strftime()@
 663 -- function.
 664
 665 formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
 666 formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
 667  = doFmt fmt
 668   where
 669    doFmt ""         = ""
 670    doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
 671    doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
 672    doFmt ('%':c:cs) = decode c ++ doFmt cs
 673    doFmt (c:cs)     = c : doFmt cs
 674
 675    decode spec =
 676     case spec of
 677       'B' -> fst (months l !! fromEnum month)
 678       'b' -> snd (months l !! fromEnum month)
 679       'h' -> snd (months l !! fromEnum month)
 680       'c' -> defaultTimeDiffFmt td
 681       'C' -> show2 (year `quot` 100)
 682       'D' -> doFmt "%m/%d/%y"
 683       'd' -> show2 day
 684       'e' -> show2' day
 685       'H' -> show2 hour
 686       'I' -> show2 (to12 hour)
 687       'k' -> show2' hour
 688       'l' -> show2' (to12 hour)
 689       'M' -> show2 min
 690       'm' -> show2 (fromEnum month + 1)
 691       'n' -> "\n"
 692       'p' -> (if hour < 12 then fst else snd) (amPm l)
 693       'R' -> doFmt "%H:%M"
 694       'r' -> doFmt (time12Fmt l)
 695       'T' -> doFmt "%H:%M:%S"
 696       't' -> "\t"
 697       'S' -> show2 sec
 698       's' -> show2 sec -- Implementation-dependent, sez the lib doc..
 699       'X' -> doFmt (timeFmt l)
 700       'x' -> doFmt (dateFmt l)
 701       'Y' -> show year
 702       'y' -> show2 (year `rem` 100)
 703       '%' -> "%"
 704       c   -> [c]
 705
 706    defaultTimeDiffFmt (TimeDiff year month day hour min sec _) =
 707        foldr (\ (v,s) rest ->
 708                   (if v /= 0
 709                      then show v ++ ' ':(addS v s)
 710                        ++ if null rest then "" else ", "
 711                      else "") ++ rest
 712              )
 713              ""
 714              (zip [year, month, day, hour, min, sec] (intervals l))
 715
 716    addS v s = if abs v == 1 then fst s else snd s
 717
 718 #ifndef __HUGS__
 719 -- -----------------------------------------------------------------------------
 720 -- Foreign time interface (POSIX)
 721
 722 type CTm = () -- struct tm
 723
 724 #if HAVE_LOCALTIME_R
 725 foreign import ccall unsafe "time.h localtime_r"
 726     localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
 727 #else
 728 foreign import ccall unsafe "time.h localtime"
 729     localtime   :: Ptr CTime -> IO (Ptr CTm)
 730 #endif
 731 #if HAVE_GMTIME_R
 732 foreign import ccall unsafe "time.h gmtime_r"
 733     gmtime_r    :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
 734 #else
 735 foreign import ccall unsafe "time.h gmtime"
 736     gmtime      :: Ptr CTime -> IO (Ptr CTm)
 737 #endif
 738 foreign import ccall unsafe "time.h mktime"
 739     mktime      :: Ptr CTm   -> IO CTime
 740
 741 #if HAVE_GETTIMEOFDAY
 742 type CTimeVal = ()
 743 type CTimeZone = ()
 744 foreign import ccall unsafe "time.h gettimeofday"
 745     gettimeofday :: Ptr CTimeVal -> Ptr CTimeZone -> IO CInt
 746 #elif HAVE_FTIME
 747 type CTimeB = ()
 748 #ifndef mingw32_HOST_OS
 749 foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO CInt
 750 #else
 751 foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO ()
 752 #endif
 753 #else
 754 foreign import ccall unsafe "time.h time" time :: Ptr CTime -> IO CTime
 755 #endif
 756 #endif /* ! __HUGS__ */