Time.hsc 21.8 KB
Newer Older
1
-- -----------------------------------------------------------------------------
2
-- $Id: Time.hsc,v 1.3 2001/01/12 16:44:13 simonmar Exp $
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
--
-- (c) The University of Glasgow, 1995-2001
--

{-
Haskell 98 Time of Day Library
------------------------------

The Time library provides standard functionality for clock times,
including timezone information (i.e, the functionality of "time.h",
adapted to the Haskell environment), It follows RFC 1129 in its use of
Coordinated Universal Time (UTC).

2000/06/17 <michael.weber@post.rwth-aachen.de>:
RESTRICTIONS:
  * min./max. time diff currently is restricted to
    [minBound::Int, maxBound::Int]

  * surely other restrictions wrt. min/max bounds


NOTES:
  * printing times

    `showTime' (used in `instance Show ClockTime') always prints time
    converted to the local timezone (even if it is taken from
    `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
    honors the tzone & tz fields and prints UTC or whatever timezone
    is stored inside CalendarTime.

    Maybe `showTime' should be changed to use UTC, since it would
    better correspond to the actual representation of `ClockTime'
    (can be done by replacing localtime(3) by gmtime(3)).


BUGS:
  * add proper handling of microsecs, currently, they're mostly
    ignored

  * `formatFOO' case of `%s' is currently broken...


TODO:
  * check for unusual date cases, like 1970/1/1 00:00h, and conversions
    between different timezone's etc.

  * check, what needs to be in the IO monad, the current situation
    seems to be a bit inconsistent to me

  * check whether `isDst = -1' works as expected on other arch's
    (Solaris anyone?)

  * add functions to parse strings to `CalendarTime' (some day...)

  * implement padding capabilities ("%_", "%-") in `formatFOO'

  * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
-}

module Time 
     (
        Month(..)
     ,  Day(..)

     ,  ClockTime(..) -- non-standard, lib. report gives this as abstract
     ,	getClockTime

     ,  TimeDiff(..)
     ,  noTimeDiff      -- non-standard (but useful when constructing TimeDiff vals.)
     ,  diffClockTimes
     ,  addToClockTime

     ,  normalizeTimeDiff -- non-standard
     ,  timeDiffToString  -- non-standard
     ,  formatTimeDiff    -- non-standard

     ,  CalendarTime(..)
     ,	toCalendarTime
     ,  toUTCTime
     ,  toClockTime
     ,  calendarTimeToString
     ,  formatCalendarTime

     ) where

#include "config.h"

#if defined(HAVE_GETTIMEOFDAY)
#  ifdef HAVE_SYS_TIME_H
#   include <sys/time.h>
#  endif
#elif defined(HAVE_GETCLOCK)
# ifdef HAVE_SYS_TIMERS_H
#  define POSIX_4D9 1
#  include <sys/timers.h>
# endif
#elif defined(HAVE_TIME_H)
# include <time.h>
#endif

#ifdef HAVE_WINDOWS_H
#include <windows.h>
#include <sys/types.h>
#include <sys/timeb.h>
#endif

import Ix
import Locale
	
import PrelMarshalAlloc
import PrelMarshalUtils
import PrelMarshalError
import PrelStorable
import PrelCString
import PrelCTypesISO
import PrelCTypes
import PrelCError
import PrelInt
import PrelPtr
import PrelIOBase
import PrelShow
import PrelNum
import PrelBase

-- One way to partition and give name to chunks of a year and a week:

data Month
 = January   | February | March    | April
 | May       | June     | July     | August
 | September | October  | November | December
 deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)

data Day 
 = Sunday   | Monday | Tuesday | Wednesday
 | Thursday | Friday | Saturday
 deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)

-- @ClockTime@ is an abstract type, used for the internal clock time.
-- Clock times may be compared, converted to strings, or converted to an
-- external calendar time @CalendarTime@.

data ClockTime = TOD Integer 		-- Seconds since 00:00:00 on 1 Jan 1970
		     Integer		-- Picoseconds with the specified second
	       deriving (Eq, Ord)

-- When a @ClockTime@ is shown, it is converted to a string of the form
-- @"Mon Nov 28 21:45:41 GMT 1994"@.

-- For now, we are restricted to roughly:
-- Fri Dec 13 20:45:52 1901 through Tue Jan 19 03:14:07 2038, because
-- we use the C library routines based on 32 bit integers.

instance Show ClockTime where
    showsPrec _ (TOD secs _nsec) = 
      showString $ unsafePerformIO $ do
	    withObject (fromIntegral secs :: CTime)  $ \ p_timer -> do
	      p_tm <- localtime p_timer -- can't fail, according to POSIX
	      allocaBytes 64 $ \ p_buf -> do  -- big enough for error message
	        r <- strftime p_buf 50 "%a %b %d %H:%M:%S %Z %Y"## p_tm
                if r == 0 
	          then return "ClockTime.show{Time}: internal error"
		  else peekCString p_buf

    showList = showList__ (showsPrec 0)

{-
@CalendarTime@ is a user-readable and manipulable
representation of the internal $ClockTime$ type.  The
numeric fields have the following ranges.

\begin{verbatim}
Value         Range             Comments
-----         -----             --------

year    -maxInt .. maxInt       [Pre-Gregorian dates are inaccurate]
mon           0 .. 11           [Jan = 0, Dec = 11]
day           1 .. 31
hour          0 .. 23
min           0 .. 59
sec           0 .. 61           [Allows for two leap seconds]
picosec       0 .. (10^12)-1    [This could be over-precise?]
wday          0 .. 6            [Sunday = 0, Saturday = 6]
yday          0 .. 365          [364 in non-Leap years]
tz       -43200 .. 43200        [Variation from UTC in seconds]
\end{verbatim}

The {\em tzname} field is the name of the time zone.  The {\em isdst}
field indicates whether Daylight Savings Time would be in effect.
-}

data CalendarTime 
 = CalendarTime  {
     ctYear    :: Int,
     ctMonth   :: Month,
     ctDay     :: Int,
     ctHour    :: Int,
     ctMin     :: Int,
     ctSec     :: Int,
     ctPicosec :: Integer,
     ctWDay    :: Day,
     ctYDay    :: Int,
     ctTZName  :: String,
     ctTZ      :: Int,
     ctIsDST   :: Bool
 }
 deriving (Eq,Ord,Read,Show)

-- The @TimeDiff@ type records the difference between two clock times in
-- a user-readable way.

data TimeDiff
 = TimeDiff {
     tdYear    :: Int,
     tdMonth   :: Int,
     tdDay     :: Int,
     tdHour    :: Int,
     tdMin     :: Int,
     tdSec     :: Int,
     tdPicosec :: Integer -- not standard
   }
   deriving (Eq,Ord,Read,Show)

noTimeDiff :: TimeDiff
noTimeDiff = TimeDiff 0 0 0 0 0 0 0

-- -----------------------------------------------------------------------------
-- getClockTime returns the current time in its internal representation.

231
232
233
234
235
236
237
238
239
240
#if HAVE_GETTIMEOFDAY
getClockTime = do
  allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
    throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
    sec  <- (#peek struct timeval,tv_sec)  p_timeval :: IO CLong
    usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CLong
    return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000))
 
#elif HAVE_FTIME && !defined(cygwin32_TARGET_OS)
  --
241
242
  -- ftime() as implemented by cygwin (in B20.1) is
  -- not right, so stay away & use time() there instead.
243
  --
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
getClockTime = do
  allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do
  ftime p_timeb
  sec  <- (#peek struct timeb,time) p_timeb :: IO CTime
  msec <- (#peek struct timeb,millitime) p_timeb :: IO CUShort
  return (TOD (fromIntegral sec) (fromIntegral msec * 1000{-ToDo: correct???-}))

#else /* use POSIX time() */
getClockTime = do
    secs <- time nullPtr -- can't fail, according to POSIX
    return (TOD (fromIntegral secs) 0)

#endif

-- -----------------------------------------------------------------------------
-- addToClockTime d t adds a time difference d and a
-- clock time t to yield a new clock time.  The difference d
-- may be either positive or negative.  diffClockTimes t1 t2 returns 
-- the difference between two clock times t1 and t2 as a TimeDiff.

addToClockTime  :: TimeDiff  -> ClockTime -> ClockTime
addToClockTime (TimeDiff year mon day hour min sec psec) 
	       (TOD c_sec c_psec) = 
	let
	  sec_diff = fromInt sec + 60 * fromInt min + 3600 * fromInt hour + 24 * 3600 * fromInt day
	  cal      = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))
                                                       -- FIXME! ^^^^
          new_mon  = fromEnum (ctMonth cal) + r_mon 
	  (month', yr_diff)
	    | new_mon < 0  = (toEnum (12 + new_mon), (-1))
	    | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
	    | otherwise    = (toEnum new_mon, 0)
	    
	  (r_yr, r_mon) = mon `quotRem` 12

          year' = ctYear cal + year + r_yr + yr_diff
	in
	toClockTime cal{ctMonth=month', ctYear=year'}

diffClockTimes  :: ClockTime -> ClockTime -> TimeDiff
-- diffClockTimes is meant to be the dual to `addToClockTime'.
-- If you want to have the TimeDiff properly splitted, use
-- `normalizeTimeDiff' on this function's result
--
-- CAVEAT: see comment of normalizeTimeDiff
diffClockTimes (TOD sa pa) (TOD sb pb) =
    noTimeDiff{ tdSec     = fromIntegral (sa - sb) 
                -- FIXME: can handle just 68 years...
              , tdPicosec = pa - pb
              }


normalizeTimeDiff :: TimeDiff -> TimeDiff
-- FIXME: handle psecs properly
-- FIXME: ?should be called by formatTimeDiff automagically?
--
-- when applied to something coming out of `diffClockTimes', you loose
-- the duality to `addToClockTime', since a year does not always have
-- 365 days, etc.
--
-- apply this function as late as possible to prevent those "rounding"
-- errors
normalizeTimeDiff td =
  let
      rest0 = tdSec td 
               + 60 * (tdMin td 
                    + 60 * (tdHour td 
                         + 24 * (tdDay td 
                              + 30 * (tdMonth td 
                                   + 365 * tdYear td))))

      (diffYears,  rest1)    = rest0 `quotRem` (365 * 24 * 3600)
      (diffMonths, rest2)    = rest1 `quotRem` (30 * 24 * 3600)
      (diffDays,   rest3)    = rest2 `quotRem` (24 * 3600)
      (diffHours,  rest4)    = rest3 `quotRem` 3600
      (diffMins,   diffSecs) = rest4 `quotRem` 60
  in
      td{ tdYear = diffYears
        , tdMonth = diffMonths
        , tdDay   = diffDays
        , tdHour  = diffHours
        , tdMin   = diffMins
        , tdSec   = diffSecs
        }

-- -----------------------------------------------------------------------------
-- toCalendarTime t converts t to a local time, modified by
-- the current timezone and daylight savings time settings.  toUTCTime
-- t converts t into UTC time.  toClockTime l converts l into the 
-- corresponding internal ClockTime.  The wday, yday, tzname, and isdst fields
-- are ignored.

#if HAVE_TM_ZONE
zone x      = (#peek struct tm,tm_zone) x   :: IO (Ptr CChar)
gmtoff x    = (#peek struct tm,tm_gmtoff) x :: IO CLong

#else /* ! HAVE_TM_ZONE */
# if HAVE_TZNAME || _WIN32
#  if cygwin32_TARGET_OS
#   define tzname _tzname
#  endif
#  ifndef mingw32_TARGET_OS
346
foreign label tzname :: Ptr (Ptr CChar)
347
#  endif
348
349
350
zone x = do 
  dst <- (#peek struct tm,tm_isdst) x
  if dst then peekArray tzname 1 else peekArray tzname 0
351
# else /* ! HAVE_TZNAME */
352
-- We're in trouble. If you should end up here, please report this as a bug.
353
354
355
#  error Dont know how to get at timezone name on your OS.
# endif /* ! HAVE_TZNAME */

356
-- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
357
358
359
360
361
#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
#define timezone _timezone
#endif

# if HAVE_ALTZONE
362
363
364
365
366
367
foreign label altzone  :: Ptr CTime
foreign label timezone :: Ptr CTime
gmtoff x = do 
  dst <- (#peek struct tm,tm_isdst) x
  tz <- if dst then peek altzone else peek timezone
  return (fromIntegral tz)
368
369
#  define GMTOFF(x)   	 (((struct tm *)x)->tm_isdst ? altzone : timezone )
# else /* ! HAVE_ALTZONE */
370
371
372
373
374
-- Assume that DST offset is 1 hour ...
gmtoff x = do 
  dst <- (#peek struct tm,tm_isdst) x
  tz  <- peek timezone
  if dst then return (fromIngtegral tz - 3600) else return tz
375
376
377
378
379
# endif /* ! HAVE_ALTZONE */
#endif  /* ! HAVE_TM_ZONE */


toCalendarTime :: ClockTime -> IO CalendarTime
380
toCalendarTime =  clockToCalendarTime localtime False
381
382

toUTCTime      :: ClockTime -> CalendarTime
383
toUTCTime      =  unsafePerformIO . clockToCalendarTime gmtime True
384
385
386

-- ToDo: should be made thread safe, because localtime uses static storage,
-- or use the localtime_r version.
387
clockToCalendarTime :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
388
	 -> IO CalendarTime
389
clockToCalendarTime fun is_utc (TOD secs psec) = do
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
  withObject (fromIntegral secs :: CTime)  $ \ p_timer -> do
    p_tm <- fun p_timer 	-- can't fail, according to POSIX
    sec   <-  (#peek struct tm,tm_sec  ) p_tm :: IO CInt
    min   <-  (#peek struct tm,tm_min  ) p_tm :: IO CInt
    hour  <-  (#peek struct tm,tm_hour ) p_tm :: IO CInt
    mday  <-  (#peek struct tm,tm_mday ) p_tm :: IO CInt
    mon   <-  (#peek struct tm,tm_mon  ) p_tm :: IO CInt
    year  <-  (#peek struct tm,tm_year ) p_tm :: IO CInt
    wday  <-  (#peek struct tm,tm_wday ) p_tm :: IO CInt
    yday  <-  (#peek struct tm,tm_yday ) p_tm :: IO CInt
    isdst <-  (#peek struct tm,tm_isdst) p_tm :: IO CInt
    zone  <-  zone p_tm
    tz    <-  gmtoff p_tm
    
    tzname <- peekCString zone
    
    let month  | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon)
    	       | otherwise             = error ("toCalendarTime: illegal month value: " ++ show mon)
    
    return (CalendarTime 
		(1900 + fromIntegral year) 
		month
		(fromIntegral mday)
		(fromIntegral hour)
		(fromIntegral min)
		(fromIntegral sec)
		psec
            	(toEnum (fromIntegral wday))
		(fromIntegral yday)
419
420
421
		(if is_utc then "UTC" else tzname)
		(if is_utc then 0     else fromIntegral tz)
		(if is_utc then False else isdst /= 0))
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611


toClockTime :: CalendarTime -> ClockTime
toClockTime (CalendarTime year mon mday hour min sec psec 
			  _wday _yday _tzname tz isdst) =

     -- `isDst' causes the date to be wrong by one hour...
     -- FIXME: check, whether this works on other arch's than Linux, too...
     -- 
     -- so we set it to (-1) (means `unknown') and let `mktime' determine
     -- the real value...
    let isDst = -1 :: CInt in   -- if isdst then (1::Int) else 0

    if psec < 0 || psec > 999999999999 then
        error "Time.toClockTime: picoseconds out of range"
    else if tz < -43200 || tz > 43200 then
        error "Time.toClockTime: timezone offset out of range"
    else
      unsafePerformIO $ do
      allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
        (#poke struct tm,tm_sec  ) p_tm	(fromIntegral sec  :: CInt)
        (#poke struct tm,tm_min  ) p_tm	(fromIntegral min  :: CInt)
        (#poke struct tm,tm_hour ) p_tm	(fromIntegral hour :: CInt)
        (#poke struct tm,tm_mday ) p_tm	(fromIntegral mday :: CInt)
        (#poke struct tm,tm_mon  ) p_tm	(fromIntegral (fromEnum mon) :: CInt)
        (#poke struct tm,tm_year ) p_tm	(fromIntegral year - 1900 :: CInt)
        (#poke struct tm,tm_isdst) p_tm	isDst
	t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input")
		(mktime p_tm)
        -- 
        -- mktime expects its argument to be in the local timezone, but
        -- toUTCTime makes UTC-encoded CalendarTime's ...
        -- 
        -- Since there is no any_tz_struct_tm-to-time_t conversion
        -- function, we have to fake one... :-) If not in all, it works in
        -- most cases (before, it was the other way round...)
        -- 
        -- Luckily, mktime tells us, what it *thinks* the timezone is, so,
        -- to compensate, we add the timezone difference to mktime's
        -- result.
        -- 
        gmtoff <- gmtoff p_tm
	let res = fromIntegral t + tz + fromIntegral gmtoff
	return (TOD (fromIntegral res) 0)

-- -----------------------------------------------------------------------------
-- Converting time values to strings.

calendarTimeToString  :: CalendarTime -> String
calendarTimeToString  =  formatCalendarTime defaultTimeLocale "%c"

formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
formatCalendarTime l fmt (CalendarTime year mon day hour min sec _
                                       wday yday tzname _ _) =
        doFmt fmt
  where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
        doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
        doFmt ('%':c:cs)   = decode c ++ doFmt cs
        doFmt (c:cs) = c : doFmt cs
        doFmt "" = ""

        decode 'A' = fst (wDays l  !! fromEnum wday) -- day of the week, full name
        decode 'a' = snd (wDays l  !! fromEnum wday) -- day of the week, abbrev.
        decode 'B' = fst (months l !! fromEnum mon)  -- month, full name
        decode 'b' = snd (months l !! fromEnum mon)  -- month, abbrev
        decode 'h' = snd (months l !! fromEnum mon)  -- ditto
        decode 'C' = show2 (year `quot` 100)         -- century
        decode 'c' = doFmt (dateTimeFmt l)           -- locale's data and time format.
        decode 'D' = doFmt "%m/%d/%y"
        decode 'd' = show2 day                       -- day of the month
        decode 'e' = show2' day                      -- ditto, padded
        decode 'H' = show2 hour                      -- hours, 24-hour clock, padded
        decode 'I' = show2 (to12 hour)               -- hours, 12-hour clock
        decode 'j' = show3 yday                      -- day of the year
        decode 'k' = show2' hour                     -- hours, 24-hour clock, no padding
        decode 'l' = show2' (to12 hour)              -- hours, 12-hour clock, no padding
        decode 'M' = show2 min                       -- minutes
        decode 'm' = show2 (fromEnum mon+1)          -- numeric month
        decode 'n' = "\n"
        decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
        decode 'R' = doFmt "%H:%M"
        decode 'r' = doFmt (time12Fmt l)
        decode 'T' = doFmt "%H:%M:%S"
        decode 't' = "\t"
        decode 'S' = show2 sec			     -- seconds
        decode 's' = show2 sec			     -- number of secs since Epoch. (ToDo.)
        decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
        decode 'u' = show (let n = fromEnum wday in  -- numeric day of the week (1=Monday, 7=Sunday)
                           if n == 0 then 7 else n)
        decode 'V' =                                 -- week number (as per ISO-8601.)
            let (week, days) =                       -- [yep, I've always wanted to be able to display that too.]
                   (yday + 7 - if fromEnum wday > 0 then 
                               fromEnum wday - 1 else 6) `divMod` 7
            in  show2 (if days >= 4 then
                          week+1 
                       else if week == 0 then 53 else week)

        decode 'W' =				     -- week number, weeks starting on monday
            show2 ((yday + 7 - if fromEnum wday > 0 then 
                               fromEnum wday - 1 else 6) `div` 7)
        decode 'w' = show (fromEnum wday)            -- numeric day of the week, weeks starting on Sunday.
        decode 'X' = doFmt (timeFmt l)               -- locale's preferred way of printing time.
        decode 'x' = doFmt (dateFmt l)               -- locale's preferred way of printing dates.
        decode 'Y' = show year                       -- year, including century.
        decode 'y' = show2 (year `rem` 100)          -- year, within century.
        decode 'Z' = tzname                          -- timezone name
        decode '%' = "%"
        decode c   = [c]


show2, show2', show3 :: Int -> String
show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]

show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x

show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)

to12 :: Int -> Int
to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'

-- Useful extensions for formatting TimeDiffs.

timeDiffToString :: TimeDiff -> String
timeDiffToString = formatTimeDiff defaultTimeLocale "%c"

formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
 = doFmt fmt
  where 
   doFmt ""         = ""
   doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
   doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
   doFmt ('%':c:cs) = decode c ++ doFmt cs
   doFmt (c:cs)     = c : doFmt cs

   decode spec =
    case spec of
      'B' -> fst (months l !! fromEnum month)
      'b' -> snd (months l !! fromEnum month)
      'h' -> snd (months l !! fromEnum month)
      'c' -> defaultTimeDiffFmt td
      'C' -> show2 (year `quot` 100)
      'D' -> doFmt "%m/%d/%y"
      'd' -> show2 day
      'e' -> show2' day
      'H' -> show2 hour
      'I' -> show2 (to12 hour)
      'k' -> show2' hour
      'l' -> show2' (to12 hour)
      'M' -> show2 min
      'm' -> show2 (fromEnum month + 1)
      'n' -> "\n"
      'p' -> (if hour < 12 then fst else snd) (amPm l)
      'R' -> doFmt "%H:%M"
      'r' -> doFmt (time12Fmt l)
      'T' -> doFmt "%H:%M:%S"
      't' -> "\t"
      'S' -> show2 sec
      's' -> show2 sec -- Implementation-dependent, sez the lib doc..
      'X' -> doFmt (timeFmt l)
      'x' -> doFmt (dateFmt l)
      'Y' -> show year
      'y' -> show2 (year `rem` 100)
      '%' -> "%"
      c   -> [c]

   defaultTimeDiffFmt (TimeDiff year month day hour min sec _) =
       foldr (\ (v,s) rest -> 
                  (if v /= 0 
                     then show v ++ ' ':(addS v s)
                       ++ if null rest then "" else ", "
                     else "") ++ rest
             )
             ""
             (zip [year, month, day, hour, min, sec] (intervals l))

   addS v s = if abs v == 1 then fst s else snd s


-- -----------------------------------------------------------------------------
-- Foreign time interface (POSIX)

type CTm = () -- struct tm

foreign import unsafe localtime :: Ptr CTime -> IO (Ptr CTm)
foreign import unsafe gmtime    :: Ptr CTime -> IO (Ptr CTm)
foreign import unsafe strftime  :: Ptr CChar -> CSize -> Addr## -> Ptr CTm -> IO CSize
foreign import unsafe mktime    :: Ptr CTm   -> IO CTime
foreign import unsafe time      :: Ptr CTime -> IO CTime

612
#if HAVE_GETTIMEOFDAY
613
614
615
616
type CTimeVal = ()
foreign import unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt
#endif

617
618
#if HAVE_FTIME
type CTimeB = ()
619
620
foreign import unsafe ftime :: Ptr CTimeB -> IO CInt
#endif