ghc/lib/std/Time.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: Time.lhs,v 1.25 2001/01/11 17:25:57 simonmar Exp $
   3 %
   4 % (c) The University of Glasgow, 1995-2000
   5 %
   6
   7 \section[Time]{Haskell 1.4 Time of Day Library}
   8
   9 The {\em Time} library provides standard functionality for
  10 clock times, including timezone information (i.e, the functionality of
  11 "time.h",  adapted to the Haskell environment), It follows RFC 1129 in
  12 its use of Coordinated Universal Time (UTC).
  13
  14 2000/06/17 <michael.weber@post.rwth-aachen.de>:
  15 RESTRICTIONS:
  16   * min./max. time diff currently is restricted to
  17     [minBound::Int, maxBound::Int]
  18
  19   * surely other restrictions wrt. min/max bounds
  20
  21
  22 NOTES:
  23   * printing times
  24
  25     `showTime' (used in `instance Show ClockTime') always prints time
  26     converted to the local timezone (even if it is taken from
  27     `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
  28     honors the tzone & tz fields and prints UTC or whatever timezone
  29     is stored inside CalendarTime.
  30
  31     Maybe `showTime' should be changed to use UTC, since it would
  32     better correspond to the actual representation of `ClockTime'
  33     (can be done by replacing localtime(3) by gmtime(3)).
  34
  35
  36 BUGS:
  37   * obvious bugs now should be fixed, but there are surely more (and
  38     less obvious one's) lurking around :-}
  39
  40   * gettimeofday(2) returns secs and _microsecs_, not pico-secs!
  41     this should be changed accordingly (also means updating the H98
  42     report)
  43
  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   * sync #ifdef'ed __HUGS__ parts with current changes (only few)
  58
  59   * check whether `isDst = -1' works as expected on other arch's
  60     (Solaris anyone?)
  61
  62   * add functions to parse strings to `CalendarTime' (some day...)
  63
  64   * implement padding capabilities ("%_", "%-") in `formatFOO'
  65
  66   * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
  67
  68
  69 \begin{code}
  70 {-# OPTIONS -#include "cbits/timezone.h" -#include "cbits/stgio.h"  #-}
  71 module Time
  72      (
  73         Month(..)
  74      ,  Day(..)
  75
  76      ,  ClockTime(..) -- non-standard, lib. report gives this as abstract
  77      ,  getClockTime
  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      ,  CalendarTime(..)
  89      ,  toCalendarTime
  90      ,  toUTCTime
  91      ,  toClockTime
  92      ,  calendarTimeToString
  93      ,  formatCalendarTime
  94
  95      ) where
  96
  97 #ifdef __HUGS__
  98 import PreludeBuiltin
  99 #else
 100 import PrelGHC          ( RealWorld, (>#), (<#), (==#),
 101                           newByteArray#, readIntArray#,
 102                           unsafeFreezeByteArray#,
 103                           int2Integer#, negateInt# )
 104 import PrelBase         ( Int(..) )
 105 import PrelNum          ( Integer(..), fromInt )
 106 import PrelIOBase       ( IO(..), unsafePerformIO, stToIO, constructErrorAndFail )
 107 import PrelShow         ( showList__ )
 108 import PrelPack         ( unpackCString, unpackCStringBA,
 109                           new_ps_array, freeze_ps_array
 110                         )
 111 import PrelByteArr      ( MutableByteArray(..), wORD_SCALE )
 112 import PrelHandle       ( Bytes )
 113 import PrelPtr
 114
 115 #endif
 116
 117 import Ix
 118 import Char             ( intToDigit )
 119 import Locale
 120
 121 \end{code}
 122
 123 One way to partition and give name to chunks of a year and a week:
 124
 125 \begin{code}
 126 data Month
 127  = January   | February | March    | April
 128  | May       | June     | July     | August
 129  | September | October  | November | December
 130  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
 131
 132 data Day
 133  = Sunday   | Monday | Tuesday | Wednesday
 134  | Thursday | Friday | Saturday
 135  deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
 136
 137 \end{code}
 138
 139 @ClockTime@ is an abstract type, used for the internal clock time.
 140 Clock times may be compared, converted to strings, or converted to an
 141 external calendar time @CalendarTime@.
 142
 143 \begin{code}
 144 #ifdef __HUGS__
 145 -- I believe Int64 is more than big enough.
 146 -- In fact, I think one of Int32 or Word32 would do. - ADR
 147 data ClockTime = TOD Int64 Int64 deriving (Eq, Ord)
 148 #else
 149 data ClockTime = TOD Integer            -- Seconds since 00:00:00 on 1 Jan 1970
 150                      Integer            -- Picoseconds with the specified second
 151                deriving (Eq, Ord)
 152
 153 #endif
 154 \end{code}
 155
 156 When a @ClockTime@ is shown, it is converted to a string of the form
 157 @"Mon Nov 28 21:45:41 GMT 1994"@.
 158
 159 For now, we are restricted to roughly:
 160 Fri Dec 13 20:45:52 1901 through Tue Jan 19 03:14:07 2038, because
 161 we use the C library routines based on 32 bit integers.
 162
 163 \begin{code}
 164 #ifdef __HUGS__
 165 #warning Show ClockTime is bogus
 166 instance Show ClockTime
 167 #else
 168 instance Show ClockTime where
 169     showsPrec p (TOD (S# i) _nsec) =
 170       case int2Integer# i of (# s, d #) -> showsPrec p (TOD (J# s d) _nsec)
 171     showsPrec _ (TOD (J# s# d#) _nsec) =
 172       showString $ unsafePerformIO $ do
 173             let buflen@(I# buflen#) = 50 -- big enough for error message
 174             buf <- allocChars buflen
 175             if s# <# (negateInt# 1#) || s# ># 1# then
 176                return "ClockTime.show{Time}: out of range"
 177              else do
 178                rc <- showTime (I# s#) d# buflen buf
 179                if rc < 0 then
 180                   return "ClockTime.show{Time}: internal error"
 181                 else do
 182                   ba <- stToIO (freeze_ps_array buf buflen#)
 183                   return (unpackCStringBA ba)
 184
 185     showList = showList__ (showsPrec 0)
 186 #endif
 187 \end{code}
 188
 189
 190 @CalendarTime@ is a user-readable and manipulable
 191 representation of the internal $ClockTime$ type.  The
 192 numeric fields have the following ranges.
 193
 194 \begin{verbatim}
 195 Value         Range             Comments
 196 -----         -----             --------
 197
 198 year    -maxInt .. maxInt       [Pre-Gregorian dates are inaccurate]
 199 mon           0 .. 11           [Jan = 0, Dec = 11]
 200 day           1 .. 31
 201 hour          0 .. 23
 202 min           0 .. 59
 203 sec           0 .. 61           [Allows for two leap seconds]
 204 picosec       0 .. (10^12)-1    [This could be over-precise?]
 205 wday          0 .. 6            [Sunday = 0, Saturday = 6]
 206 yday          0 .. 365          [364 in non-Leap years]
 207 tz       -43200 .. 43200        [Variation from UTC in seconds]
 208 \end{verbatim}
 209
 210 The {\em tzname} field is the name of the time zone.  The {\em isdst}
 211 field indicates whether Daylight Savings Time would be in effect.
 212
 213 \begin{code}
 214 data CalendarTime
 215  = CalendarTime  {
 216      ctYear    :: Int,
 217      ctMonth   :: Month,
 218      ctDay     :: Int,
 219      ctHour    :: Int,
 220      ctMin     :: Int,
 221      ctSec     :: Int,
 222 #ifdef __HUGS__
 223      ctPicosec :: Int64,
 224 #else
 225      ctPicosec :: Integer,
 226 #endif
 227      ctWDay    :: Day,
 228      ctYDay    :: Int,
 229      ctTZName  :: String,
 230      ctTZ      :: Int,
 231      ctIsDST   :: Bool
 232  }
 233  deriving (Eq,Ord,Read,Show)
 234
 235 \end{code}
 236
 237 The @TimeDiff@ type records the difference between two clock times in
 238 a user-readable way.
 239
 240 \begin{code}
 241 data TimeDiff
 242  = TimeDiff {
 243      tdYear    :: Int,
 244      tdMonth   :: Int,
 245      tdDay     :: Int,
 246      tdHour    :: Int,
 247      tdMin     :: Int,
 248      tdSec     :: Int,
 249 #ifdef __HUGS__
 250      tdPicosec :: Int64   -- not standard
 251 #else
 252      tdPicosec :: Integer -- not standard
 253 #endif
 254    }
 255    deriving (Eq,Ord,Read,Show)
 256
 257 noTimeDiff :: TimeDiff
 258 noTimeDiff = TimeDiff 0 0 0 0 0 0 0
 259 \end{code}
 260
 261 @getClockTime@ returns the current time in its internal representation.
 262
 263 \begin{code}
 264 getClockTime :: IO ClockTime
 265 getClockTime = do
 266     i1 <- malloc1
 267     i2 <- malloc1
 268     rc <- primGetClockTime i1 i2
 269     if rc == 0
 270         then do
 271             sec  <- cvtUnsigned i1
 272             nsec <- cvtUnsigned i2
 273             return (TOD sec (nsec * 1000))
 274         else
 275             constructErrorAndFail "getClockTime"
 276
 277 #ifdef __HUGS__
 278 malloc1 = primNewByteArray sizeof_int64
 279 cvtUnsigned arr = primReadInt64Array arr 0
 280 #else
 281 malloc1 :: IO (MutableByteArray RealWorld Int)
 282 malloc1 = IO $ \ s# ->
 283   case newByteArray# 1# s# of
 284    (# s2#, barr# #) -> (# s2#, MutableByteArray bot bot barr# #)
 285   where
 286         bot = error "Time.malloc1"
 287
 288    --  The C routine fills in an unsigned word.  We don't have
 289    --   `unsigned2Integer#,' so we freeze the data bits and use them
 290    --   for an MP_INT structure.  Note that zero is still handled specially,
 291    --   although (J# 1# (ptr to 0#)) is probably acceptable to gmp.
 292
 293 cvtUnsigned :: MutableByteArray RealWorld Int -> IO Integer
 294 cvtUnsigned (MutableByteArray _ _ arr#) = IO $ \ s# ->
 295   case readIntArray# arr# 0# s# of
 296     (# s2#, r# #) | r# ==# 0#  -> (# s2#, 0 #)
 297                   | otherwise  ->
 298                      case unsafeFreezeByteArray# arr# s2# of
 299                        (# s3#, frozen# #) -> (# s3#, J# 1# frozen# #)
 300 #endif
 301 \end{code}
 302
 303 @addToClockTime@ {\em d} {\em t} adds a time difference {\em d} and a
 304 clock time {\em t} to yield a new clock time.  The difference {\em d}
 305 may be either positive or negative.  @[diffClockTimes@ {\em t1} {\em
 306 t2} returns the difference between two clock times {\em t1} and {\em
 307 t2} as a @TimeDiff@.
 308
 309
 310 \begin{code}
 311 addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime
 312 addToClockTime (TimeDiff year mon day hour min sec psec)
 313                (TOD c_sec c_psec) =
 314         let
 315           sec_diff = fromInt sec + 60 * fromInt min + 3600 * fromInt hour + 24 * 3600 * fromInt day
 316           cal      = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))
 317                                                        -- FIXME! ^^^^
 318           new_mon  = fromEnum (ctMonth cal) + r_mon
 319           (month', yr_diff)
 320             | new_mon < 0  = (toEnum (12 + new_mon), (-1))
 321             | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
 322             | otherwise    = (toEnum new_mon, 0)
 323
 324           (r_yr, r_mon) = mon `quotRem` 12
 325
 326           year' = ctYear cal + year + r_yr + yr_diff
 327         in
 328         toClockTime cal{ctMonth=month', ctYear=year'}
 329
 330 diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff
 331 -- diffClockTimes is meant to be the dual to `addToClockTime'.
 332 -- If you want to have the TimeDiff properly splitted, use
 333 -- `normalizeTimeDiff' on this function's result
 334 --
 335 -- CAVEAT: see comment of normalizeTimeDiff
 336 diffClockTimes (TOD sa pa) (TOD sb pb) =
 337     noTimeDiff{ tdSec     = fromIntegral (sa - sb)
 338                 -- FIXME: can handle just 68 years...
 339               , tdPicosec = pa - pb
 340               }
 341
 342
 343 normalizeTimeDiff :: TimeDiff -> TimeDiff
 344 -- FIXME: handle psecs properly
 345 -- FIXME: ?should be called by formatTimeDiff automagically?
 346 --
 347 -- when applied to something coming out of `diffClockTimes', you loose
 348 -- the duality to `addToClockTime', since a year does not always have
 349 -- 365 days, etc.
 350 --
 351 -- apply this function as late as possible to prevent those "rounding"
 352 -- errors
 353 normalizeTimeDiff td =
 354   let
 355       rest0 = tdSec td
 356                + 60 * (tdMin td
 357                     + 60 * (tdHour td
 358                          + 24 * (tdDay td
 359                               + 30 * (tdMonth td
 360                                    + 365 * tdYear td))))
 361
 362       (diffYears,  rest1)    = rest0 `quotRem` (365 * 24 * 3600)
 363       (diffMonths, rest2)    = rest1 `quotRem` (30 * 24 * 3600)
 364       (diffDays,   rest3)    = rest2 `quotRem` (24 * 3600)
 365       (diffHours,  rest4)    = rest3 `quotRem` 3600
 366       (diffMins,   diffSecs) = rest4 `quotRem` 60
 367   in
 368       td{ tdYear = diffYears
 369         , tdMonth = diffMonths
 370         , tdDay   = diffDays
 371         , tdHour  = diffHours
 372         , tdMin   = diffMins
 373         , tdSec   = diffSecs
 374         }
 375
 376 \end{code}
 377
 378 @toCalendarTime@ {\em t} converts {\em t} to a local time, modified by
 379 the current timezone and daylight savings time settings.  @toUTCTime@
 380 {\em t} converts {\em t} into UTC time.  @toClockTime@ {\em l}
 381 converts {\em l} into the corresponding internal @ClockTime@.  The
 382 {\em wday}, {\em yday}, {\em tzname}, and {\em isdst} fields are
 383 ignored.
 384
 385 \begin{code}
 386 #ifdef __HUGS__
 387 toCalendarTime :: ClockTime -> IO CalendarTime
 388 toCalendarTime (TOD sec psec) = do
 389     res    <- allocWords sizeof_int64
 390     zoneNm <- allocChars 32
 391     prim_SETZONE res zoneNm
 392     rc <- prim_toLocalTime sec res
 393     if rc /= 0
 394      then constructErrorAndFail "Time.toCalendarTime: out of range"
 395      else do
 396        sec   <-  get_tm_sec   res
 397        min   <-  get_tm_min   res
 398        hour  <-  get_tm_hour  res
 399        mday  <-  get_tm_mday  res
 400        mon   <-  get_tm_mon   res
 401        year  <-  get_tm_year  res
 402        wday  <-  get_tm_wday  res
 403        yday  <-  get_tm_yday  res
 404        isdst <-  get_tm_isdst res
 405        zone  <-  prim_ZONE    res
 406        tz    <-  prim_GMTOFF  res
 407        tzname <- primUnpackCString zone
 408        return (CalendarTime (1900+year) mon mday hour min sec psec
 409                             (toEnum wday) yday tzname tz (isdst /= 0))
 410
 411 toUTCTime :: ClockTime -> CalendarTime
 412 toUTCTime  (TOD sec psec) = unsafePerformIO $ do
 413        res    <- allocWords sizeof_int64
 414        zoneNm <- allocChars 32
 415        prim_SETZONE res zoneNm
 416        rc <- prim_toUTCTime sec res
 417        if rc /= 0
 418         then error "Time.toUTCTime: out of range"
 419         else do
 420             sec   <- get_tm_sec  res
 421             min   <- get_tm_min  res
 422             hour  <- get_tm_hour res
 423             mday  <- get_tm_mday res
 424             mon   <- get_tm_mon  res
 425             year  <- get_tm_year res
 426             wday  <- get_tm_wday res
 427             yday  <- get_tm_yday res
 428             return (CalendarTime (1900+year) mon mday hour min sec psec
 429                           (toEnum wday) yday "UTC" 0 False)
 430
 431 toClockTime :: CalendarTime -> ClockTime
 432 toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz isdst) =
 433     if psec < 0 || psec > 999999999999 then
 434         error "Time.toClockTime: picoseconds out of range"
 435     else if tz < -43200 || tz > 43200 then
 436         error "Time.toClockTime: timezone offset out of range"
 437     else
 438         unsafePerformIO ( do
 439             res <- allocWords sizeof_int64
 440             rc <- toClockSec year (fromEnum mon) mday hour min sec isDst res
 441             if rc /= (0::Int)
 442              then do
 443                tm <- primReadInt64Array res 0
 444                return (TOD tm psec)
 445              else error "Time.toClockTime: can't perform conversion"
 446         )
 447     where
 448      isDst = if isdst then (1::Int) else 0
 449
 450 #else
 451 toCalendarTime :: ClockTime -> IO CalendarTime
 452 toCalendarTime (TOD (S# i) psec)
 453   = case int2Integer# i of (# s, d #) -> toCalendarTime (TOD (J# s d) psec)
 454 toCalendarTime (TOD (J# s# d#) psec) = do
 455     res    <- allocWords sizeof_struct_tm
 456     zoneNm <- allocChars 32
 457     prim_SETZONE res zoneNm
 458     rc     <- prim_toLocalTime (I# s#) d# res
 459     if rc == 0
 460      then constructErrorAndFail "Time.toCalendarTime: out of range"
 461      else do
 462        sec   <-  get_tm_sec res
 463        min   <-  get_tm_min res
 464        hour  <-  get_tm_hour res
 465        mday  <-  get_tm_mday res
 466        mon   <-  get_tm_mon  res
 467        year  <-  get_tm_year res
 468        wday  <-  get_tm_wday res
 469        yday  <-  get_tm_yday res
 470        isdst <-  get_tm_isdst res
 471        zone  <-  get_ZONE res
 472        tz    <-  get_GMTOFF res
 473        let tzname = unpackCString zone
 474            month
 475             | mon >= 0 && mon <= 11 = toEnum mon
 476             | otherwise             = error ("toCalendarTime: illegal month value: " ++ show mon)
 477
 478        return (CalendarTime (1900+year) month mday hour min sec psec
 479                             (toEnum wday) yday tzname tz (isdst /= (0::Int)))
 480
 481 toUTCTime :: ClockTime -> CalendarTime
 482 toUTCTime (TOD (S# i) psec)
 483   = case int2Integer# i of (# s, d #) -> toUTCTime (TOD (J# s d) psec)
 484 toUTCTime  (TOD (J# s# d#) psec) = unsafePerformIO $ do
 485        res    <- allocWords sizeof_struct_tm
 486        zoneNm <- allocChars 32
 487        prim_SETZONE res zoneNm
 488        rc     <-  prim_toUTCTime (I# s#) d# res
 489        if rc == 0
 490         then error "Time.toUTCTime: out of range"
 491         else do
 492             sec   <- get_tm_sec res
 493             min   <- get_tm_min res
 494             hour  <- get_tm_hour res
 495             mday  <- get_tm_mday res
 496             mon   <- get_tm_mon res
 497             year  <- get_tm_year res
 498             wday  <- get_tm_wday res
 499             yday  <- get_tm_yday res
 500             let
 501              month
 502               | mon >= 0 && mon <= 11 = toEnum mon
 503               | otherwise             = error ("toCalendarTime: illegal month value: " ++ show mon)
 504
 505             return (CalendarTime (1900+year) month mday hour min sec psec
 506                           (toEnum wday) yday "UTC" 0 False)
 507
 508 toClockTime :: CalendarTime -> ClockTime
 509 toClockTime (CalendarTime year mon mday hour min sec psec _wday _yday _tzname tz isdst) =
 510     if psec < 0 || psec > 999999999999 then
 511         error "Time.toClockTime: picoseconds out of range"
 512     else if tz < -43200 || tz > 43200 then
 513         error "Time.toClockTime: timezone offset out of range"
 514     else
 515         unsafePerformIO ( do
 516             res <- malloc1
 517             rc  <- toClockSec year (fromEnum mon) mday hour min sec tz isDst res
 518             if rc /= 0
 519              then do
 520                i <- cvtUnsigned res
 521                return (TOD i psec)
 522              else error "Time.toClockTime: can't perform conversion"
 523         )
 524     where
 525      -- `isDst' causes the date to be wrong by one hour...
 526      -- FIXME: check, whether this works on other arch's than Linux, too...
 527      --
 528      -- so we set it to (-1) (means `unknown') and let `mktime' determine
 529      -- the real value...
 530      isDst = -1     -- if isdst then (1::Int) else 0
 531 #endif
 532
 533
 534 -- (copied from PosixUtil, for now)
 535 -- Allocate a mutable array of characters with no indices.
 536
 537 #ifdef __HUGS__
 538 allocChars :: Int -> IO (PrimMutableByteArray RealWorld)
 539 allocChars size = primNewByteArray size
 540
 541 -- Allocate a mutable array of words with no indices
 542
 543 allocWords :: Int -> IO (PrimMutableByteArray RealWorld)
 544 allocWords size = primNewByteArray size
 545 #else
 546 allocChars :: Int -> IO (MutableByteArray RealWorld Int)
 547 allocChars (I# size#) = stToIO (new_ps_array size#)
 548
 549 -- Allocate a mutable array of words with no indices
 550
 551 allocWords :: Int -> IO (MutableByteArray RealWorld Int)
 552 allocWords (I# size#) = IO $ \ s# ->
 553     case newByteArray# (wORD_SCALE size#) s# of
 554       (# s2#, barr# #) ->
 555         (# s2#, MutableByteArray bot bot barr# #)
 556   where
 557     bot = error "Time.allocWords"
 558 #endif
 559 \end{code}
 560
 561 \begin{code}
 562 calendarTimeToString  :: CalendarTime -> String
 563 calendarTimeToString  =  formatCalendarTime defaultTimeLocale "%c"
 564
 565 formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
 566 formatCalendarTime l fmt (CalendarTime year mon day hour min sec _
 567                                        wday yday tzname _ _) =
 568         doFmt fmt
 569   where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
 570         doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
 571         doFmt ('%':c:cs)   = decode c ++ doFmt cs
 572         doFmt (c:cs) = c : doFmt cs
 573         doFmt "" = ""
 574
 575         decode 'A' = fst (wDays l  !! fromEnum wday) -- day of the week, full name
 576         decode 'a' = snd (wDays l  !! fromEnum wday) -- day of the week, abbrev.
 577         decode 'B' = fst (months l !! fromEnum mon)  -- month, full name
 578         decode 'b' = snd (months l !! fromEnum mon)  -- month, abbrev
 579         decode 'h' = snd (months l !! fromEnum mon)  -- ditto
 580         decode 'C' = show2 (year `quot` 100)         -- century
 581         decode 'c' = doFmt (dateTimeFmt l)           -- locale's data and time format.
 582         decode 'D' = doFmt "%m/%d/%y"
 583         decode 'd' = show2 day                       -- day of the month
 584         decode 'e' = show2' day                      -- ditto, padded
 585         decode 'H' = show2 hour                      -- hours, 24-hour clock, padded
 586         decode 'I' = show2 (to12 hour)               -- hours, 12-hour clock
 587         decode 'j' = show3 yday                      -- day of the year
 588         decode 'k' = show2' hour                     -- hours, 24-hour clock, no padding
 589         decode 'l' = show2' (to12 hour)              -- hours, 12-hour clock, no padding
 590         decode 'M' = show2 min                       -- minutes
 591         decode 'm' = show2 (fromEnum mon+1)          -- numeric month
 592         decode 'n' = "\n"
 593         decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
 594         decode 'R' = doFmt "%H:%M"
 595         decode 'r' = doFmt (time12Fmt l)
 596         decode 'T' = doFmt "%H:%M:%S"
 597         decode 't' = "\t"
 598         decode 'S' = show2 sec                       -- seconds
 599         decode 's' = show2 sec                       -- number of secs since Epoch. (ToDo.)
 600         decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
 601         decode 'u' = show (let n = fromEnum wday in  -- numeric day of the week (1=Monday, 7=Sunday)
 602                            if n == 0 then 7 else n)
 603         decode 'V' =                                 -- week number (as per ISO-8601.)
 604             let (week, days) =                       -- [yep, I've always wanted to be able to display that too.]
 605                    (yday + 7 - if fromEnum wday > 0 then
 606                                fromEnum wday - 1 else 6) `divMod` 7
 607             in  show2 (if days >= 4 then
 608                           week+1
 609                        else if week == 0 then 53 else week)
 610
 611         decode 'W' =                                 -- week number, weeks starting on monday
 612             show2 ((yday + 7 - if fromEnum wday > 0 then
 613                                fromEnum wday - 1 else 6) `div` 7)
 614         decode 'w' = show (fromEnum wday)            -- numeric day of the week, weeks starting on Sunday.
 615         decode 'X' = doFmt (timeFmt l)               -- locale's preferred way of printing time.
 616         decode 'x' = doFmt (dateFmt l)               -- locale's preferred way of printing dates.
 617         decode 'Y' = show year                       -- year, including century.
 618         decode 'y' = show2 (year `rem` 100)          -- year, within century.
 619         decode 'Z' = tzname                          -- timezone name
 620         decode '%' = "%"
 621         decode c   = [c]
 622
 623
 624 show2, show2', show3 :: Int -> String
 625 show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]
 626
 627 show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x
 628
 629 show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
 630
 631 to12 :: Int -> Int
 632 to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
 633 \end{code}
 634
 635 Useful extensions for formatting TimeDiffs.
 636
 637 \begin{code}
 638 timeDiffToString :: TimeDiff -> String
 639 timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
 640
 641 formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
 642 formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
 643  = doFmt fmt
 644   where
 645    doFmt ""         = ""
 646    doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
 647    doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
 648    doFmt ('%':c:cs) = decode c ++ doFmt cs
 649    doFmt (c:cs)     = c : doFmt cs
 650
 651    decode spec =
 652     case spec of
 653       'B' -> fst (months l !! fromEnum month)
 654       'b' -> snd (months l !! fromEnum month)
 655       'h' -> snd (months l !! fromEnum month)
 656       'c' -> defaultTimeDiffFmt td
 657       'C' -> show2 (year `quot` 100)
 658       'D' -> doFmt "%m/%d/%y"
 659       'd' -> show2 day
 660       'e' -> show2' day
 661       'H' -> show2 hour
 662       'I' -> show2 (to12 hour)
 663       'k' -> show2' hour
 664       'l' -> show2' (to12 hour)
 665       'M' -> show2 min
 666       'm' -> show2 (fromEnum month + 1)
 667       'n' -> "\n"
 668       'p' -> (if hour < 12 then fst else snd) (amPm l)
 669       'R' -> doFmt "%H:%M"
 670       'r' -> doFmt (time12Fmt l)
 671       'T' -> doFmt "%H:%M:%S"
 672       't' -> "\t"
 673       'S' -> show2 sec
 674       's' -> show2 sec -- Implementation-dependent, sez the lib doc..
 675       'X' -> doFmt (timeFmt l)
 676       'x' -> doFmt (dateFmt l)
 677       'Y' -> show year
 678       'y' -> show2 (year `rem` 100)
 679       '%' -> "%"
 680       c   -> [c]
 681
 682    defaultTimeDiffFmt (TimeDiff year month day hour min sec _) =
 683        foldr (\ (v,s) rest ->
 684                   (if v /= 0
 685                      then show v ++ ' ':(addS v s)
 686                        ++ if null rest then "" else ", "
 687                      else "") ++ rest
 688              )
 689              ""
 690              (zip [year, month, day, hour, min, sec] (intervals l))
 691
 692    addS v s = if abs v == 1 then fst s else snd s
 693 \end{code}
 694
 695 \begin{code}
 696 foreign import "libHS_cbits" "get_tm_sec"   unsafe get_tm_sec   :: MBytes -> IO Int
 697 foreign import "libHS_cbits" "get_tm_min"   unsafe get_tm_min   :: MBytes -> IO Int
 698 foreign import "libHS_cbits" "get_tm_hour"  unsafe get_tm_hour  :: MBytes -> IO Int
 699 foreign import "libHS_cbits" "get_tm_mday"  unsafe get_tm_mday  :: MBytes -> IO Int
 700 foreign import "libHS_cbits" "get_tm_mon"   unsafe get_tm_mon   :: MBytes -> IO Int
 701 foreign import "libHS_cbits" "get_tm_year"  unsafe get_tm_year  :: MBytes -> IO Int
 702 foreign import "libHS_cbits" "get_tm_wday"  unsafe get_tm_wday  :: MBytes -> IO Int
 703 foreign import "libHS_cbits" "get_tm_yday"  unsafe get_tm_yday  :: MBytes -> IO Int
 704 foreign import "libHS_cbits" "get_tm_isdst" unsafe get_tm_isdst :: MBytes -> IO Int
 705
 706 foreign import "libHS_cbits" "sizeof_struct_tm" unsafe sizeof_struct_tm :: Int
 707
 708 #ifdef __HUGS__
 709 -- believed to be at least 1 bit (the sign bit!) bigger than sizeof_time_t
 710 sizeof_int64 :: Int
 711 sizeof_int64 = 8
 712 #endif
 713
 714 type MBytes = MutableByteArray RealWorld Int
 715
 716 foreign import "libHS_cbits" "sizeof_time_t" unsafe sizeof_time_t    :: Int
 717
 718 foreign import "libHS_cbits" "prim_SETZONE" unsafe prim_SETZONE :: MBytes -> MBytes -> IO ()
 719 #ifdef __HUGS__
 720 foreign import "libHS_cbits" "prim_toLocalTime"  unsafe prim_toLocalTime :: Int64 -> MBytes -> IO Int
 721 foreign import "libHS_cbits" "prim_toUTCTime"    unsafe prim_toUTCTime   :: Int64 -> MBytes -> IO Int
 722 foreign import "libHS_cbits" "prim_ZONE"    unsafe prim_ZONE    :: Bytes -> IO (Ptr ())
 723 foreign import "libHS_cbits" "prim_GMTOFF"  unsafe prim_GMTOFF  :: Bytes -> IO Int
 724 #else
 725 foreign import "libHS_cbits" "toLocalTime"  unsafe prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int
 726 foreign import "libHS_cbits" "toUTCTime"    unsafe prim_toUTCTime   :: Int -> Bytes -> MBytes -> IO Int
 727 #endif
 728
 729 foreign import "libHS_cbits" "get_ZONE"  unsafe get_ZONE   :: MBytes -> IO (Ptr ())
 730 foreign import "libHS_cbits" "GMTOFF"    unsafe get_GMTOFF :: MBytes -> IO Int
 731
 732
 733 foreign import "libHS_cbits" "toClockSec" unsafe
 734             toClockSec   :: Int -> Int -> Int -> Int -> Int
 735                          -> Int -> Int -> Int -> MBytes -> IO Int
 736
 737 foreign import "libHS_cbits" "getClockTime"  unsafe
 738            primGetClockTime :: MutableByteArray RealWorld Int
 739                             -> MutableByteArray RealWorld Int
 740                             -> IO Int
 741 foreign import "libHS_cbits" "showTime" unsafe
 742            showTime :: Int
 743                     -> Bytes
 744                     -> Int
 745                     -> MBytes
 746                     -> IO Int
 747 \end{code}