ghc/lib/std/Time.hsc

   1 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
   2 -- JRS 010117: we had to say NON_POSIX_SOURCE to get the resulting .hc
   3 -- to compile on sparc-solaris.  Blargh.
   4
   5 -- -----------------------------------------------------------------------------
   6 -- $Id: Time.hsc,v 1.11 2001/04/07 14:58:44 lewie Exp $
   7 --
   8 -- (c) The University of Glasgow, 1995-2001
   9 --
  10
  11 {-
  12 Haskell 98 Time of Day Library
  13 ------------------------------
  14
  15 The Time library provides standard functionality for clock times,
  16 including timezone information (i.e, the functionality of "time.h",
  17 adapted to the Haskell environment), It follows RFC 1129 in its use of
  18 Coordinated Universal Time (UTC).
  19
  20 2000/06/17 <michael.weber@post.rwth-aachen.de>:
  21 RESTRICTIONS:
  22   * min./max. time diff currently is restricted to
  23     [minBound::Int, maxBound::Int]
  24
  25   * surely other restrictions wrt. min/max bounds
  26
  27
  28 NOTES:
  29   * printing times
  30
  31     `showTime' (used in `instance Show ClockTime') always prints time
  32     converted to the local timezone (even if it is taken from
  33     `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
  34     honors the tzone & tz fields and prints UTC or whatever timezone
  35     is stored inside CalendarTime.
  36
  37     Maybe `showTime' should be changed to use UTC, since it would
  38     better correspond to the actual representation of `ClockTime'
  39     (can be done by replacing localtime(3) by gmtime(3)).
  40
  41
  42 BUGS:
  43   * add proper handling of microsecs, currently, they're mostly
  44     ignored
  45
  46   * `formatFOO' case of `%s' is currently broken...
  47
  48
  49 TODO:
  50   * check for unusual date cases, like 1970/1/1 00:00h, and conversions
  51     between different timezone's etc.
  52
  53   * check, what needs to be in the IO monad, the current situation
  54     seems to be a bit inconsistent to me
  55
  56   * check whether `isDst = -1' works as expected on other arch's
  57     (Solaris anyone?)
  58
  59   * add functions to parse strings to `CalendarTime' (some day...)
  60
  61   * implement padding capabilities ("%_", "%-") in `formatFOO'
  62
  63   * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
  64 -}
  65
  66 module Time
  67      (
  68         Month(..)
  69      ,  Day(..)
  70
  71      ,  ClockTime(..) -- non-standard, lib. report gives this as abstract
  72      ,  getClockTime
  73
  74      ,  TimeDiff(..)
  75      ,  noTimeDiff      -- non-standard (but useful when constructing TimeDiff vals.)
  76      ,  diffClockTimes
  77      ,  addToClockTime
  78
  79      ,  normalizeTimeDiff -- non-standard
  80      ,  timeDiffToString  -- non-standard
  81      ,  formatTimeDiff    -- non-standard
  82
  83      ,  CalendarTime(..)
  84      ,  toCalendarTime
  85      ,  toUTCTime
  86      ,  toClockTime
  87      ,  calendarTimeToString
  88      ,  formatCalendarTime
  89
  90      ) where
  91
  92 #include "config.h"
  93
  94 #if defined(HAVE_GETTIMEOFDAY)
  95 #  ifdef HAVE_SYS_TIME_H
  96 #   include <sys/time.h>
  97 #  endif
  98 #elif defined(HAVE_GETCLOCK)
  99 # ifdef HAVE_SYS_TIMERS_H
 100 #  define POSIX_4D9 1
 101 #  include <sys/timers.h>
 102 # endif
 103 #endif
 104
 105 #if defined(HAVE_TIME_H)
 106 # include <time.h>
 107 #endif
 108
 109 #ifdef HAVE_SYS_TYPES_H
 110 #include <sys/types.h>
 111 #endif
 112
 113 #ifdef HAVE_SYS_TIMEB_H
 114 #include <sys/timeb.h>
 115 #endif
 116
 117 #ifdef HAVE_WINDOWS_H
 118 #include <windows.h>
 119 #endif
 120
 121 import Ix
 122 import Locale
 123
 124 import PrelMarshalAlloc
 125 import PrelMarshalUtils
 126 import PrelMarshalError
 127 import PrelStorable
 128 import PrelCString
 129 import PrelCTypesISO
 130 import PrelCTypes
 131 import PrelCError
 132 import PrelInt
 133 import PrelPtr
 134 import PrelIOBase
 135 import PrelShow
 136 import PrelNum
 137 import PrelBase
 138
 139 -- One way to partition and give name to chunks of a year and a week:
 140
 141 data Month
 142  = January   | February | March    | April
 143  | May       | June     | July     | August
 144  | September | October  | November | December
 145  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
 146
 147 data Day
 148  = Sunday   | Monday | Tuesday | Wednesday
 149  | Thursday | Friday | Saturday
 150  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
 151
 152 -- @ClockTime@ is an abstract type, used for the internal clock time.
 153 -- Clock times may be compared, converted to strings, or converted to an
 154 -- external calendar time @CalendarTime@.
 155
 156 data ClockTime = TOD Integer            -- Seconds since 00:00:00 on 1 Jan 1970
 157                      Integer            -- Picoseconds with the specified second
 158                deriving (Eq, Ord)
 159
 160 -- When a @ClockTime@ is shown, it is converted to a string of the form
 161 -- @"Mon Nov 28 21:45:41 GMT 1994"@.
 162
 163 -- For now, we are restricted to roughly:
 164 -- Fri Dec 13 20:45:52 1901 through Tue Jan 19 03:14:07 2038, because
 165 -- we use the C library routines based on 32 bit integers.
 166
 167 instance Show ClockTime where
 168     showsPrec _ (TOD secs _nsec) =
 169       showString $ unsafePerformIO $ do
 170             withObject (fromIntegral secs :: CTime)  $ \ p_timer -> do
 171               p_tm <- localtime p_timer -- can't fail, according to POSIX
 172               allocaBytes 64 $ \ p_buf -> do  -- big enough for error message
 173                 r <- strftime p_buf 50 "%a %b %d %H:%M:%S %Z %Y"## p_tm
 174                 if r == 0
 175                   then return "ClockTime.show{Time}: internal error"
 176                   else peekCString p_buf
 177
 178     showList = showList__ (showsPrec 0)
 179
 180 {-
 181 @CalendarTime@ is a user-readable and manipulable
 182 representation of the internal $ClockTime$ type.  The
 183 numeric fields have the following ranges.
 184
 185 \begin{verbatim}
 186 Value         Range             Comments
 187 -----         -----             --------
 188
 189 year    -maxInt .. maxInt       [Pre-Gregorian dates are inaccurate]
 190 mon           0 .. 11           [Jan = 0, Dec = 11]
 191 day           1 .. 31
 192 hour          0 .. 23
 193 min           0 .. 59
 194 sec           0 .. 61           [Allows for two leap seconds]
 195 picosec       0 .. (10^12)-1    [This could be over-precise?]
 196 wday          0 .. 6            [Sunday = 0, Saturday = 6]
 197 yday          0 .. 365          [364 in non-Leap years]
 198 tz       -43200 .. 43200        [Variation from UTC in seconds]
 199 \end{verbatim}
 200
 201 The {\em tzname} field is the name of the time zone.  The {\em isdst}
 202 field indicates whether Daylight Savings Time would be in effect.
 203 -}
 204
 205 data CalendarTime
 206  = CalendarTime  {
 207      ctYear    :: Int,
 208      ctMonth   :: Month,
 209      ctDay     :: Int,
 210      ctHour    :: Int,
 211      ctMin     :: Int,
 212      ctSec     :: Int,
 213      ctPicosec :: Integer,
 214      ctWDay    :: Day,
 215      ctYDay    :: Int,
 216      ctTZName  :: String,
 217      ctTZ      :: Int,
 218      ctIsDST   :: Bool
 219  }
 220  deriving (Eq,Ord,Read,Show)
 221
 222 -- The @TimeDiff@ type records the difference between two clock times in
 223 -- a user-readable way.
 224
 225 data TimeDiff
 226  = TimeDiff {
 227      tdYear    :: Int,
 228      tdMonth   :: Int,
 229      tdDay     :: Int,
 230      tdHour    :: Int,
 231      tdMin     :: Int,
 232      tdSec     :: Int,
 233      tdPicosec :: Integer -- not standard
 234    }
 235    deriving (Eq,Ord,Read,Show)
 236
 237 noTimeDiff :: TimeDiff
 238 noTimeDiff = TimeDiff 0 0 0 0 0 0 0
 239
 240 -- -----------------------------------------------------------------------------
 241 -- getClockTime returns the current time in its internal representation.
 242
 243 #if HAVE_GETTIMEOFDAY
 244 getClockTime = do
 245   allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
 246     throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
 247     sec  <- (#peek struct timeval,tv_sec)  p_timeval :: IO CLong
 248     usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CLong
 249     return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000))
 250
 251 #elif HAVE_FTIME
 252 getClockTime = do
 253   allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do
 254   ftime p_timeb
 255   sec  <- (#peek struct timeb,time) p_timeb :: IO CTime
 256   msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort
 257   return (TOD (fromIntegral sec) (fromIntegral msec * 1000{-ToDo: correct???-}))
 258
 259 #else /* use POSIX time() */
 260 getClockTime = do
 261     secs <- time nullPtr -- can't fail, according to POSIX
 262     return (TOD (fromIntegral secs) 0)
 263
 264 #endif
 265
 266 -- -----------------------------------------------------------------------------
 267 -- addToClockTime d t adds a time difference d and a
 268 -- clock time t to yield a new clock time.  The difference d
 269 -- may be either positive or negative.  diffClockTimes t1 t2 returns
 270 -- the difference between two clock times t1 and t2 as a TimeDiff.
 271
 272 addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime
 273 addToClockTime (TimeDiff year mon day hour min sec psec)
 274                (TOD c_sec c_psec) =
 275         let
 276           sec_diff = toInteger sec +
 277                      60 * toInteger min +
 278                      3600 * toInteger hour +
 279                      24 * 3600 * toInteger day
 280           cal      = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))
 281                                                        -- FIXME! ^^^^
 282           new_mon  = fromEnum (ctMonth cal) + r_mon
 283           (month', yr_diff)
 284             | new_mon < 0  = (toEnum (12 + new_mon), (-1))
 285             | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
 286             | otherwise    = (toEnum new_mon, 0)
 287
 288           (r_yr, r_mon) = mon `quotRem` 12
 289
 290           year' = ctYear cal + year + r_yr + yr_diff
 291         in
 292         toClockTime cal{ctMonth=month', ctYear=year'}
 293
 294 diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff
 295 -- diffClockTimes is meant to be the dual to `addToClockTime'.
 296 -- If you want to have the TimeDiff properly splitted, use
 297 -- `normalizeTimeDiff' on this function's result
 298 --
 299 -- CAVEAT: see comment of normalizeTimeDiff
 300 diffClockTimes (TOD sa pa) (TOD sb pb) =
 301     noTimeDiff{ tdSec     = fromIntegral (sa - sb)
 302                 -- FIXME: can handle just 68 years...
 303               , tdPicosec = pa - pb
 304               }
 305
 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 = tdSec td
 320                + 60 * (tdMin td
 321                     + 60 * (tdHour td
 322                          + 24 * (tdDay td
 323                               + 30 * (tdMonth td
 324                                    + 365 * 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 = diffYears
 333         , tdMonth = diffMonths
 334         , tdDay   = diffDays
 335         , tdHour  = diffHours
 336         , tdMin   = diffMins
 337         , tdSec   = diffSecs
 338         }
 339
 340 -- -----------------------------------------------------------------------------
 341 -- How do we deal with timezones on this architecture?
 342
 343 -- The POSIX way to do it is through the global variable tzname[].
 344 -- But that's crap, so we do it The BSD Way if we can: namely use the
 345 -- tm_zone and tm_gmtoff fields of struct tm, if they're available.
 346
 347 zone   :: Ptr CTm -> IO (Ptr CChar)
 348 gmtoff :: Ptr CTm -> IO CLong
 349 #if HAVE_TM_ZONE
 350 zone x      = (#peek struct tm,tm_zone) x
 351 gmtoff x    = (#peek struct tm,tm_gmtoff) x
 352
 353 #else /* ! HAVE_TM_ZONE */
 354 # if HAVE_TZNAME || _WIN32
 355 #  if cygwin32_TARGET_OS
 356 #   define tzname _tzname
 357 #  endif
 358 #  ifndef mingw32_TARGET_OS
 359 foreign label tzname :: Ptr (Ptr CChar)
 360 #  else
 361 foreign import "ghcTimezone" unsafe timezone :: Ptr CLong
 362 foreign import "ghcTzname" unsafe tzname :: Ptr (Ptr CChar)
 363 #   def inline long  *ghcTimezone(void) { return &_timezone; }
 364 #   def inline char **ghcTzname(void) { return _tzname; }
 365 #  endif
 366 zone x = do
 367   dst <- (#peek struct tm,tm_isdst) x
 368   if dst then peekElemOff tzname 1 else peekElemOff tzname 0
 369 # else /* ! HAVE_TZNAME */
 370 -- We're in trouble. If you should end up here, please report this as a bug.
 371 #  error "Don't know how to get at timezone name on your OS."
 372 # endif /* ! HAVE_TZNAME */
 373
 374 -- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
 375 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
 376 #define timezone _timezone
 377 #endif
 378
 379 # if HAVE_ALTZONE
 380 foreign label altzone  :: Ptr CTime
 381 foreign label timezone :: Ptr CTime
 382 gmtoff x = do
 383   dst <- (#peek struct tm,tm_isdst) x
 384   tz <- if dst then peek altzone else peek timezone
 385   return (fromIntegral tz)
 386 #  define GMTOFF(x)      (((struct tm *)x)->tm_isdst ? altzone : timezone )
 387 # else /* ! HAVE_ALTZONE */
 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   if dst then return (fromIntegral tz - 3600) else return tz
 393 # endif /* ! HAVE_ALTZONE */
 394 #endif  /* ! HAVE_TM_ZONE */
 395
 396 -- -----------------------------------------------------------------------------
 397 -- toCalendarTime t converts t to a local time, modified by
 398 -- the current timezone and daylight savings time settings.  toUTCTime
 399 -- t converts t into UTC time.  toClockTime l converts l into the
 400 -- corresponding internal ClockTime.  The wday, yday, tzname, and isdst fields
 401 -- are ignored.
 402
 403
 404 toCalendarTime :: ClockTime -> IO CalendarTime
 405 toCalendarTime =  clockToCalendarTime localtime False
 406
 407 toUTCTime      :: ClockTime -> CalendarTime
 408 toUTCTime      =  unsafePerformIO . clockToCalendarTime gmtime True
 409
 410 -- ToDo: should be made thread safe, because localtime uses static storage,
 411 -- or use the localtime_r version.
 412 clockToCalendarTime :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
 413          -> IO CalendarTime
 414 clockToCalendarTime fun is_utc (TOD secs psec) = do
 415   withObject (fromIntegral secs :: CTime)  $ \ p_timer -> do
 416     p_tm <- fun p_timer         -- can't fail, according to POSIX
 417     sec   <-  (#peek struct tm,tm_sec  ) p_tm :: IO CInt
 418     min   <-  (#peek struct tm,tm_min  ) p_tm :: IO CInt
 419     hour  <-  (#peek struct tm,tm_hour ) p_tm :: IO CInt
 420     mday  <-  (#peek struct tm,tm_mday ) p_tm :: IO CInt
 421     mon   <-  (#peek struct tm,tm_mon  ) p_tm :: IO CInt
 422     year  <-  (#peek struct tm,tm_year ) p_tm :: IO CInt
 423     wday  <-  (#peek struct tm,tm_wday ) p_tm :: IO CInt
 424     yday  <-  (#peek struct tm,tm_yday ) p_tm :: IO CInt
 425     isdst <-  (#peek struct tm,tm_isdst) p_tm :: IO CInt
 426     zone  <-  zone p_tm
 427     tz    <-  gmtoff p_tm
 428
 429     tzname <- peekCString zone
 430
 431     let month  | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon)
 432                | otherwise             = error ("toCalendarTime: illegal month value: " ++ show mon)
 433
 434     return (CalendarTime
 435                 (1900 + fromIntegral year)
 436                 month
 437                 (fromIntegral mday)
 438                 (fromIntegral hour)
 439                 (fromIntegral min)
 440                 (fromIntegral sec)
 441                 psec
 442                 (toEnum (fromIntegral wday))
 443                 (fromIntegral yday)
 444                 (if is_utc then "UTC" else tzname)
 445                 (if is_utc then 0     else fromIntegral tz)
 446                 (if is_utc then False else isdst /= 0))
 447
 448
 449 toClockTime :: CalendarTime -> ClockTime
 450 toClockTime (CalendarTime year mon mday hour min sec psec
 451                           _wday _yday _tzname tz isdst) =
 452
 453      -- `isDst' causes the date to be wrong by one hour...
 454      -- FIXME: check, whether this works on other arch's than Linux, too...
 455      --
 456      -- so we set it to (-1) (means `unknown') and let `mktime' determine
 457      -- the real value...
 458     let isDst = -1 :: CInt in   -- if isdst then (1::Int) else 0
 459
 460     if psec < 0 || psec > 999999999999 then
 461         error "Time.toClockTime: picoseconds out of range"
 462     else if tz < -43200 || tz > 43200 then
 463         error "Time.toClockTime: timezone offset out of range"
 464     else
 465       unsafePerformIO $ do
 466       allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
 467         (#poke struct tm,tm_sec  ) p_tm (fromIntegral sec  :: CInt)
 468         (#poke struct tm,tm_min  ) p_tm (fromIntegral min  :: CInt)
 469         (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
 470         (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)
 471         (#poke struct tm,tm_mon  ) p_tm (fromIntegral (fromEnum mon) :: CInt)
 472         (#poke struct tm,tm_year ) p_tm (fromIntegral year - 1900 :: CInt)
 473         (#poke struct tm,tm_isdst) p_tm isDst
 474         t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input")
 475                 (mktime p_tm)
 476         --
 477         -- mktime expects its argument to be in the local timezone, but
 478         -- toUTCTime makes UTC-encoded CalendarTime's ...
 479         --
 480         -- Since there is no any_tz_struct_tm-to-time_t conversion
 481         -- function, we have to fake one... :-) If not in all, it works in
 482         -- most cases (before, it was the other way round...)
 483         --
 484         -- Luckily, mktime tells us, what it *thinks* the timezone is, so,
 485         -- to compensate, we add the timezone difference to mktime's
 486         -- result.
 487         --
 488         gmtoff <- gmtoff p_tm
 489         let res = fromIntegral t + tz - fromIntegral gmtoff
 490         return (TOD (fromIntegral res) 0)
 491
 492 -- -----------------------------------------------------------------------------
 493 -- Converting time values to strings.
 494
 495 calendarTimeToString  :: CalendarTime -> String
 496 calendarTimeToString  =  formatCalendarTime defaultTimeLocale "%c"
 497
 498 formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
 499 formatCalendarTime l fmt (CalendarTime year mon day hour min sec _
 500                                        wday yday tzname _ _) =
 501         doFmt fmt
 502   where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
 503         doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
 504         doFmt ('%':c:cs)   = decode c ++ doFmt cs
 505         doFmt (c:cs) = c : doFmt cs
 506         doFmt "" = ""
 507
 508         decode 'A' = fst (wDays l  !! fromEnum wday) -- day of the week, full name
 509         decode 'a' = snd (wDays l  !! fromEnum wday) -- day of the week, abbrev.
 510         decode 'B' = fst (months l !! fromEnum mon)  -- month, full name
 511         decode 'b' = snd (months l !! fromEnum mon)  -- month, abbrev
 512         decode 'h' = snd (months l !! fromEnum mon)  -- ditto
 513         decode 'C' = show2 (year `quot` 100)         -- century
 514         decode 'c' = doFmt (dateTimeFmt l)           -- locale's data and time format.
 515         decode 'D' = doFmt "%m/%d/%y"
 516         decode 'd' = show2 day                       -- day of the month
 517         decode 'e' = show2' day                      -- ditto, padded
 518         decode 'H' = show2 hour                      -- hours, 24-hour clock, padded
 519         decode 'I' = show2 (to12 hour)               -- hours, 12-hour clock
 520         decode 'j' = show3 yday                      -- day of the year
 521         decode 'k' = show2' hour                     -- hours, 24-hour clock, no padding
 522         decode 'l' = show2' (to12 hour)              -- hours, 12-hour clock, no padding
 523         decode 'M' = show2 min                       -- minutes
 524         decode 'm' = show2 (fromEnum mon+1)          -- numeric month
 525         decode 'n' = "\n"
 526         decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
 527         decode 'R' = doFmt "%H:%M"
 528         decode 'r' = doFmt (time12Fmt l)
 529         decode 'T' = doFmt "%H:%M:%S"
 530         decode 't' = "\t"
 531         decode 'S' = show2 sec                       -- seconds
 532         decode 's' = show2 sec                       -- number of secs since Epoch. (ToDo.)
 533         decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
 534         decode 'u' = show (let n = fromEnum wday in  -- numeric day of the week (1=Monday, 7=Sunday)
 535                            if n == 0 then 7 else n)
 536         decode 'V' =                                 -- week number (as per ISO-8601.)
 537             let (week, days) =                       -- [yep, I've always wanted to be able to display that too.]
 538                    (yday + 7 - if fromEnum wday > 0 then
 539                                fromEnum wday - 1 else 6) `divMod` 7
 540             in  show2 (if days >= 4 then
 541                           week+1
 542                        else if week == 0 then 53 else week)
 543
 544         decode 'W' =                                 -- week number, weeks starting on monday
 545             show2 ((yday + 7 - if fromEnum wday > 0 then
 546                                fromEnum wday - 1 else 6) `div` 7)
 547         decode 'w' = show (fromEnum wday)            -- numeric day of the week, weeks starting on Sunday.
 548         decode 'X' = doFmt (timeFmt l)               -- locale's preferred way of printing time.
 549         decode 'x' = doFmt (dateFmt l)               -- locale's preferred way of printing dates.
 550         decode 'Y' = show year                       -- year, including century.
 551         decode 'y' = show2 (year `rem` 100)          -- year, within century.
 552         decode 'Z' = tzname                          -- timezone name
 553         decode '%' = "%"
 554         decode c   = [c]
 555
 556
 557 show2, show2', show3 :: Int -> String
 558 show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]
 559
 560 show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x
 561
 562 show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
 563
 564 to12 :: Int -> Int
 565 to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
 566
 567 -- Useful extensions for formatting TimeDiffs.
 568
 569 timeDiffToString :: TimeDiff -> String
 570 timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
 571
 572 formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
 573 formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
 574  = doFmt fmt
 575   where
 576    doFmt ""         = ""
 577    doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
 578    doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
 579    doFmt ('%':c:cs) = decode c ++ doFmt cs
 580    doFmt (c:cs)     = c : doFmt cs
 581
 582    decode spec =
 583     case spec of
 584       'B' -> fst (months l !! fromEnum month)
 585       'b' -> snd (months l !! fromEnum month)
 586       'h' -> snd (months l !! fromEnum month)
 587       'c' -> defaultTimeDiffFmt td
 588       'C' -> show2 (year `quot` 100)
 589       'D' -> doFmt "%m/%d/%y"
 590       'd' -> show2 day
 591       'e' -> show2' day
 592       'H' -> show2 hour
 593       'I' -> show2 (to12 hour)
 594       'k' -> show2' hour
 595       'l' -> show2' (to12 hour)
 596       'M' -> show2 min
 597       'm' -> show2 (fromEnum month + 1)
 598       'n' -> "\n"
 599       'p' -> (if hour < 12 then fst else snd) (amPm l)
 600       'R' -> doFmt "%H:%M"
 601       'r' -> doFmt (time12Fmt l)
 602       'T' -> doFmt "%H:%M:%S"
 603       't' -> "\t"
 604       'S' -> show2 sec
 605       's' -> show2 sec -- Implementation-dependent, sez the lib doc..
 606       'X' -> doFmt (timeFmt l)
 607       'x' -> doFmt (dateFmt l)
 608       'Y' -> show year
 609       'y' -> show2 (year `rem` 100)
 610       '%' -> "%"
 611       c   -> [c]
 612
 613    defaultTimeDiffFmt (TimeDiff year month day hour min sec _) =
 614        foldr (\ (v,s) rest ->
 615                   (if v /= 0
 616                      then show v ++ ' ':(addS v s)
 617                        ++ if null rest then "" else ", "
 618                      else "") ++ rest
 619              )
 620              ""
 621              (zip [year, month, day, hour, min, sec] (intervals l))
 622
 623    addS v s = if abs v == 1 then fst s else snd s
 624
 625
 626 -- -----------------------------------------------------------------------------
 627 -- Foreign time interface (POSIX)
 628
 629 type CTm = () -- struct tm
 630
 631 foreign import unsafe localtime :: Ptr CTime -> IO (Ptr CTm)
 632 foreign import unsafe gmtime    :: Ptr CTime -> IO (Ptr CTm)
 633 foreign import unsafe strftime  :: Ptr CChar -> CSize -> Addr## -> Ptr CTm -> IO CSize
 634 foreign import unsafe mktime    :: Ptr CTm   -> IO CTime
 635 foreign import unsafe time      :: Ptr CTime -> IO CTime
 636
 637 #if HAVE_GETTIMEOFDAY
 638 type CTimeVal = ()
 639 foreign import unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt
 640 #endif
 641
 642 #if HAVE_FTIME
 643 type CTimeB = ()
 644 #ifndef mingw32_TARGET_OS
 645 foreign import unsafe ftime :: Ptr CTimeB -> IO CInt
 646 #else
 647 foreign import unsafe ftime :: Ptr CTimeB -> IO ()
 648 #endif
 649 #endif