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